C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C    - REMOVE TABS
C    - PROGRAM UNITS RE-ORDERED
C    - ADDITIONAL YADEFS INCLUSIONS REMOVED
C    - DEFINES MOVED
C    - UNSPLIT LINES REMOVED
C    - CHANGE ZCTYPE TO ZPTYPE
C    - USE NEW TOKEN WRITE ROUTINE, CHANGE IODTKO/IODCMO FOR
C      TKNCHN AND USE ZTKPTI AS AN INITIALISATION CALL.
C    - REMOVE USE OF IODCMT FOR TOKEN OUTPUT
C    - CHANGE CLAB AND GETIL TO SELECT UNIQUE NUMBERS/LABELS AND
C      REMOVE THE NEED FOR THE SCRATCH FILE......
C    - CHANGE COMMON BLOCK /IO/
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
 
 
 
 
 
 
 
 
C                                   parameter length
 
 
 
 
 
 
 
 
 
C following are for ZYCSDT (Canonicalise Symbol Data Types)
C
      PROGRAM ISTCD
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C THIS IS USED BY BOTH ISTSB AND ISTCD
C
C This COMMON block contains the logical variable ITERAT which is
C set to .TRUE. when a condition is encountered that implies that
C further processing is required on the parse tree obtained from
C the token stream output from the current run.  ZQUIT is called
C with condition 'repeat' if and only if ITERAT is .TRUE.
C
C This COMMON block contains the logical variables ITERAT and CYCLE.
 
      COMMON /REPEAT/ ITERAT,CYCLE
      LOGICAL ITERAT,CYCLE
 
      INTEGER TKNPTH(81),CIPTH(81),
     +        TKOPTH(81),CMOPTH(81),CMTPTH(81),
     +        NERROR,NWARN
 
      INTEGER OPEN,CREATE,GETARG,ZGTCMD,CTOI,ZYINCI,YPARSE
      EXTERNAL OPEN,CREATE,ERROR,ZINIT,ZQUIT,ZMESS,
     +           GETARG,ZGTCMD,CTOI,ZPTINT,SEEK,PUTCH,YPARSE
 
      SAVE
 
        DATA (CIPTH(I),I=1,10)/35,
     +99,100,99,109,105,116,109,112,129/
 
      CALL ZINIT
 
      IF (GETARG(1,TKNPTH,81).EQ.-100) CALL NAMES(1,TKNPTH)
      IF (GETARG(2,CMTPTH,81).EQ.-100) CALL NAMES(2,CMTPTH)
      IF (GETARG(3,TKOPTH,81).EQ.-100) CALL NAMES(3,TKOPTH)
      IF (GETARG(4,CMOPTH,81).EQ.-100) CALL NAMES(4,CMOPTH)
 
      IODCMI = CREATE(CIPTH,2)
      IF (IODCMI.EQ.-1) CALL ERROR('Can''t create scratch file.')
 
      IODTKN=OPEN(TKNPTH,0)
      IF (IODTKN.EQ.-1) CALL ERROR('Can''t open token stream.')
      IODCMT=OPEN(CMTPTH,0)
      IF (IODCMT.EQ.-1) CALL ERROR('Can''t open comment file.')
      IODTKO=CREATE(TKOPTH,1)
      IF (IODTKO.EQ.-1) CALL ERROR('Can''t create token stream.')
      IODCMO=CREATE(CMOPTH,1)
      IF (IODCMO.EQ.-1) CALL ERROR('Can''t create comment stream.')
 
      CALL INISTR
      CALL INISYM
      CALL INITRE
      NERROR = 0
      NWARN = 0
      IF(YPARSE(IODTKN,IODCMT,-1,IODCMI,NERROR,NWARN).NE.0) THEN
        CALL ERROR('[ISTCD - PARSER FATAL ERROR].')
      ENDIF
      IF(NERROR .GT. 0) THEN
        CALL ERROR('[ISTCD - PARSER ERRORS REPORTED].')
      ENDIF
 
      CALL SEEK(0, IODCMI)
      CALL SEEK(0, IODCMT)
      IF(ZYINCI(IODCMI) .EQ. -1) CALL ERROR('[ISTCD - ZYINCI ERROR].')
 
C Initialize ITERAT and CYCLE (in COMMON block REPEAT).
      ITERAT = .FALSE.
      CYCLE = .FALSE.
 
      CALL PROFIL
 
C CYCLE takes precedence over ITERAT.
      IF (CYCLE) THEN
         CALL ZMESS('[ISTCD Normal Termination].',2)
         CALL ZMESS('[ ** Cycle ISTSB/ISTCD ** ].',2)
         CALL ZQUIT(-2001)
      ELSE IF (ITERAT) THEN
         CALL ZMESS('[ISTCD Normal Termination].',2)
         CALL ZMESS('[ ** Repeat ISTCD ** ].',2)
         CALL ZQUIT(-2000)
      ELSE
         CALL ZMESS('[ISTCD Normal Termination].',2)
         CALL ZQUIT(-2)
      END IF
 
      END
C ----------------------------------------------------------------------
C
      SUBROUTINE NAMES (NUMBER,PATH)
 
      INTEGER NUMBER,PATH(81)
 
      INTEGER ZGTCMD
      EXTERNAL ZGTCMD,ZPRMPT
 
      INTEGER JUNK,PROMPT(24,4)
 
      SAVE PROMPT
 
C "Input token stream:"
C "Input comment stream: "
C "Output token stream: "
C "Output comment stream: "
 
      DATA (PROMPT(I,1),I=1,21)/73,110,112,117,116,32,116,
     +111,107,101,110,32,115,116,114,101,97,109,
     +58,32,129/,
     +       (PROMPT(I,2),I=1,23)/73,110,112,117,116,32,99,
     +111,109,109,101,110,116,32,115,116,114,101,97,109,
     +58,32,129/,
     +       (PROMPT(I,3),I=1,22)/79,117,116,112,117,116,32,
     +116,111,107,101,110,32,115,116,114,101,97,109,
     +58,32,129/,
     +       (PROMPT(I,4),I=1,24)/79,117,116,112,117,116,32,
     +99,111,109,109,101,110,116,32,115,116,114,101,97,
     +109,58,32,129/
 
      CALL ZPRMPT(PROMPT(1,NUMBER))
      JUNK=ZGTCMD(PATH,0)
 
      END
C ----------------------------------------------------------------------
C
C       P R O F I L   -   Process files
C
 
      SUBROUTINE PROFIL
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C THIS IS USED BY BOTH ISTSB AND ISTCD
C
C This COMMON block contains the logical variable ITERAT which is
C set to .TRUE. when a condition is encountered that implies that
C further processing is required on the parse tree obtained from
C the token stream output from the current run.  ZQUIT is called
C with condition 'repeat' if and only if ITERAT is .TRUE.
C
C This COMMON block contains the logical variables ITERAT and CYCLE.
 
      COMMON /REPEAT/ ITERAT,CYCLE
      LOGICAL ITERAT,CYCLE
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
      COMMON /CLAB/ CURLBL,CURPUN,FIRST
      LOGICAL FIRST
      INTEGER CURLBL,CURPUN
      INTEGER TEXT(134), SYMVAL(8)
 
      INTEGER PTR
      INTEGER ZYDOWN,ZYNEXT,ZYROOT,ZTKPTI,ZYGPUS
      EXTERNAL ZYDOWN,ZYNEXT,ZYROOT,ZTOKWR,ZTKPTI
 
      SAVE
 
      TKNCHN = ZTKPTI(1, IODTKO, IODCMO)
      IF(TKNCHN .EQ. -1) CALL ERROR('[ISTCD - Output Stream Failure].')
 
      PTR=ZYDOWN(ZYROOT())
      CURPUN = 0
 
 100  IF (PTR.GT.0) THEN
         CURLBL = 59999
         CURPUN = CURPUN + 1
         FIRST = .TRUE.
         CALL ZYGTSY(ZYGPUS(CURPUN), SYMVAL)
         CALL ZYGTST(SYMVAL(2), TEXT)
         CALL ZCHOUT('CD Processing: ', 2)
         CALL ZPTMES(TEXT, 2)
         CALL PROPU(PTR)
         PTR=ZYNEXT(PTR)
         GO TO 100
      END IF
      CALL ZTOKWR(TZEOF,0,TEXT,TKNCHN)
 
      END
C-----------------------   CHKDOP.MAC
C ---------------------------------------------------------------------
C        C H K D O P - Check three conditions associated with Paradigm PEQ.
C                      Output comment(s), through calls to COMDEP when
C                      conditions are violated and return 'no'. If conditions
C                     are satisfied, return 'yes' and a comment referring
C                      to the user's guide.
C
C The conditions are:
C   (1) Every statement in the range of every DO is an assignment.
C
C   (2) The lhs of every statement in the range of every DO is an
C       array element with one subscript which is the (common) DO
C       variable.  (Let LHSARN contain the set of names of arrays that
C       appear on the lhs of statements in the ranges of the DOs.)
C
C   (3) In every appearance on the rhs of any statement in any DO of an
C       array named in LHSARN, each subscript is of form N+C or N-C where
C       N is a name and C is a constant integer .ge. 0.  If C > 0, then
C       N is NOT the DO variable.
 
       INTEGER FUNCTION CHKDOP(VAR,FIRST,LAST,NRDOS)
 
       INTEGER VAR(*),FIRST(*),LAST(*),NRDOS
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
       INTEGER SPTR,LHSNOD,INDNAM(7),LHSARN(7,200),NRARN,
     +          ARNAM(7),INDPTR,NAMNOD,NPIPTR,POINTR,RHSNOD,
     +          STACK(500),TYPE,JUNK(7),JSTR1(7),
     +          CSTR1(7),PLUS, I, J
 
       INTEGER NODETP,ZYDOWN,ZYNEXT,EQUAL,POP,PUSH,JPMC
       SAVE
       EXTERNAL NODETP,ZYDOWN,ZYNEXT,GETSTR,EQUAL,POP,PUSH,
     +           COMDEP,JPMC
 
       CHKDOP = -2
       NRARN = 0
       STACK(1) = -1
 
C Check conditions PEQ-A and PEQ-B.
       DO 10 I = 1,NRDOS
          SPTR = FIRST(I)
40          CONTINUE
C Is statement an assignment?
          IF (NODETP(SPTR) .NE. 49) THEN
             CALL COMDEP(2,JUNK)
             CHKDOP = -3
             GO TO 140
          END IF
 
C Is lhs an array element?
          LHSNOD = ZYDOWN(SPTR)
          IF (NODETP(LHSNOD) .EQ. 115) LHSNOD = ZYNEXT(LHSNOD)
C LHSNOD is node of lhs.
          IF (NODETP(LHSNOD) .NE. 104) THEN
             CALL COMDEP(33,JUNK)
             CHKDOP = -3
             GO TO 140
          END IF
 
C Save the name of the array element in LHSARN.
C NRARN the number of names in the set.  Names may be duplicates.
          LHSNOD = ZYDOWN(LHSNOD)
C LHSNOD is now node of array name.
          NRARN = NRARN + 1
          IF (NRARN .GT. 200) CALL ERROR('CHKDOP: Increase Size '//
     +                         'of Array LHSARN.')
          CALL GETSTR(LHSNOD,LHSARN(1,NRARN))
 
C Get subscript - make sure it's a name.
          LHSNOD = ZYNEXT(LHSNOD)
60          CONTINUE
          IF (NODETP(LHSNOD) .EQ. 101) THEN
             LHSNOD = ZYDOWN(LHSNOD)
             GO TO 60
          END IF
C LHSNOD is now node of subscript.
 
          IF (NODETP(LHSNOD) .NE. 108) THEN
             CALL COMDEP(3,LHSARN(1,NRARN))
             CHKDOP = -3
             GO TO 140
          END IF
 
C Is subscript the DO variable?
          CALL GETSTR(LHSNOD,INDNAM)
          IF (EQUAL(INDNAM,VAR) .NE. -2) THEN
              CALL COMDEP(3,LHSARN(1,NRARN))
             CHKDOP = -3
          END IF
 
          LHSNOD = ZYNEXT(LHSNOD)
C Is there another subscript?
          IF (LHSNOD .NE. 0) THEN
              CALL COMDEP(3,LHSARN(1,NRARN))
             CHKDOP = -3
          END IF
 
140          CONTINUE
          IF (SPTR .NE. LAST(I)) THEN
             SPTR = ZYNEXT(SPTR)
             GO TO 40
          END IF
 
10       CONTINUE
 
C Check condition PEQ-C.
       DO 100 I = 1,NRDOS
          SPTR = FIRST(I)
120          CONTINUE
 
C Get node of rhs.
          RHSNOD = ZYDOWN(SPTR)
          IF (NODETP(RHSNOD) .EQ. 115) RHSNOD = ZYNEXT(RHSNOD)
          RHSNOD = ZYNEXT(RHSNOD)
 
          POINTR = RHSNOD
70          CONTINUE
            TYPE = NODETP(POINTR)
          IF(TYPE .EQ. 104) THEN
 
C If the name of the array is not in LHSARN continue the search
C of the rhs.
             NAMNOD = ZYDOWN(POINTR)
             CALL GETSTR(NAMNOD,ARNAM)
             DO 80 J=1,NRARN
                IF (EQUAL(ARNAM,LHSARN(1,J)) .EQ. -2) GO TO 90
80             CONTINUE
               GO TO 110
90             CONTINUE
C The name of the array is in LHSARN.
             INDPTR = ZYNEXT(NAMNOD)
 
C INDPTR is the node of an subscript. Remove parentheses.
50             NPIPTR = INDPTR
30             CONTINUE
             IF (NODETP(NPIPTR) .EQ. 101) THEN
                NPIPTR = ZYDOWN(NPIPTR)
                GO TO 30
             END IF
 
C NPIPTR is the node of the subscript with parentheses removed.
             IF (JPMC(NPIPTR,JSTR1,CSTR1,PLUS) .EQ. -3) THEN
                CALL COMDEP(4,ARNAM)
                CHKDOP = -3
             END IF
 
C Subscript is of form N, N+C, or N-C.  In the latter two cases,
C N cannot be the DO variable.
             IF (PLUS .NE. 0) THEN
                IF (EQUAL(JSTR1,VAR) .EQ. -2) THEN
                   CALL COMDEP(4,ARNAM)
                   CHKDOP = -3
                END IF
             END IF
 
             INDPTR = ZYNEXT(INDPTR)
C Is there another subscript?
             IF (INDPTR .NE. 0) GO TO 50
          END IF
110          CONTINUE
          IF(PUSH(POINTR,STACK) .EQ. -1)CALL ERROR('Stack Full.',2)
          POINTR = ZYDOWN(POINTR)
C If POINTR > 0, node is not a leaf.
          IF(POINTR .GT. 0) GO TO 70
C Node is a leaf.
C Can't go down, try next unless we are at RHSNOD.
          POINTR = POP(STACK)
          IF(POINTR .EQ. RHSNOD) GO TO 130
 
          POINTR = ZYNEXT(POINTR)
          IF(POINTR .GT. 0) GO TO 70
C Can't go next, pop until next is possible or return to RHSNOD is complete.
            POINTR = POP(STACK)
          IF(POINTR .EQ. -1 .OR. POINTR .EQ. RHSNOD) GO TO 130
20          CONTINUE
          POINTR = ZYNEXT(POINTR)
          IF(POINTR .GT. 0) THEN
             GO TO 70
          ELSE
             POINTR = POP(STACK)
             IF(POINTR .EQ. -1 .OR. POINTR .EQ. RHSNOD) GO TO 130
             GO TO 20
          END IF
 
130          CONTINUE
          IF (SPTR .NE. LAST(I)) THEN
             SPTR = ZYNEXT(SPTR)
             GO TO 120
          END IF
100       CONTINUE
 
       IF (CHKDOP .EQ. -2) CALL COMDEP(5,JUNK)
       CALL COMDEP(1,JUNK)
 
       END
C-----------------------   CHKEQV.MAC
C ---------------------------------------------------------------------
C        C H K E Q V - Check equivalence of parameters E1,E2
C                      in a DO sequence.
C
      SUBROUTINE CHKEQV(E1,E2,SEQLEN,E1SAME,E2SAME)
C If the first SEQLEN of the E1 parameters are equivalent, return
C E1SAME = .TRUE., otherwise, E1SAME = .FALSE. Similarly for the E2
C parameters and E2SAME.  Parentheses are removed for comparison.
 
      INTEGER E1(*),E2(*),SEQLEN
      LOGICAL E1SAME,E2SAME
 
      INTEGER NPE1(50),NPE2(50), I
      INTEGER COMPAR,NODETP,ZYDOWN
      EXTERNAL COMPAR,NODETP,ZYDOWN
 
      E1SAME = .FALSE.
      E2SAME = .FALSE.
 
C Remove parentheses for comparison.
      DO 5 I = 1,SEQLEN
         NPE1(I) = E1(I)
70         CONTINUE
         IF (NODETP(NPE1(I)) .EQ. 101) THEN
            NPE1(I) = ZYDOWN(NPE1(I))
            GO TO 70
         END IF
         NPE2(I) = E2(I)
80         CONTINUE
         IF (NODETP(NPE2(I)) .EQ. 101) THEN
            NPE2(I) = ZYDOWN(NPE2(I))
            GO TO 80
         END IF
5      CONTINUE
 
      DO 10 I=2,SEQLEN
         IF (COMPAR(NPE1(1),NPE1(I)) .EQ. -3) GO TO 100
10      CONTINUE
      E1SAME = .TRUE.
 
100      CONTINUE
      DO 20 I=2,SEQLEN
         IF (COMPAR(NPE2(1),NPE2(I)) .EQ. -3) GO TO 200
20      CONTINUE
      E2SAME = .TRUE.
 
200   CONTINUE
      END
C-----------------------   CHKIND.MAC
C   I N D J P 1
C
       INTEGER FUNCTION INDJP1(NODE,NAME,CONST)
C Return 'yes' or 'no' according to whether, in the subtree rooted
C at NODE, every index of every array element is of form NAME or
C NAME + KON where val(KON) is any of val(CONST),val(CONST)-1,...,1.
C (KON and CONST are represented as strings.)
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
      INTEGER NODE,NAME(*),CONST(*),POINTR,TYPE,INDPTR,NPIPTR,
     +          STACK(500),KON(4),
     +          NUM1,VALKON,VALCNS,JSTR(10),PLUS,JPMC
 
      INTEGER ZYROOT, NODETP, ZYDOWN, ZYNEXT, ZYUP, PUSH, POP,
     +          EQUAL,CTOI
      SAVE
      EXTERNAL ZYINPT, ZYROOT, ZPTINT, NODETP, ZYDOWN, ZCHOUT,
     +           ZYNEXT, ZYUP, PUSH, POP, ZYGTSY,
     +           ZYGTST, ZPTMES, EQUAL, SCOPY, GETSTR,CTOI
 
      STACK(1) = -1
 
      POINTR = NODE
   10 CONTINUE
        TYPE = NODETP(POINTR)
        IF(TYPE .EQ. 104) THEN
          INDPTR = ZYNEXT(ZYDOWN(POINTR))
C INDPTR is the node of an index. Remove parentheses.
50          NPIPTR = INDPTR
30          CONTINUE
          IF (NODETP(NPIPTR) .EQ. 101) THEN
             NPIPTR = ZYDOWN(NPIPTR)
             GO TO 30
          END IF
 
          IF (JPMC(NPIPTR,JSTR,KON,PLUS) .EQ. -3) THEN
             INDJP1 = -3
             RETURN
          END IF
 
C The index is of form J, J+c, or J-c.
          IF (PLUS .EQ. -1) THEN
             INDJP1 = -3
             RETURN
          END IF
 
C The index is of form  J or J + c.  Is J = NAME?
          IF (EQUAL(JSTR,NAME) .EQ. -3) THEN
             INDJP1 = -3
             RETURN
          END IF
 
          IF (PLUS .EQ. 0) GO TO 40
 
C The index is of form J + c.  Is c = CONST or CONST-1 or ... or 1?
          NUM1 = 1
          VALKON = CTOI(KON,NUM1)
          NUM1 = 1
          VALCNS = CTOI(CONST,NUM1)
          IF ((VALKON .GT. VALCNS) .OR. (VALKON .LT. 1)) THEN
             INDJP1 = -3
             RETURN
          END IF
 
40        CONTINUE
 
C The index is of form NAME + KON.  Go on to the next index.
          INDPTR = ZYNEXT(INDPTR)
          IF (INDPTR .GT. 0) GO TO 50
       END IF
       IF(PUSH(POINTR,STACK) .EQ. -1)CALL ERROR('Stack Full.',2)
       POINTR = ZYDOWN(POINTR)
C If POINTR > 0, node is not a leaf.
       IF(POINTR .GT. 0) GO TO 10
C Node is a leaf.
C Can't go down, try next unless we are at NODE.
       POINTR = POP(STACK)
       IF(POINTR .EQ. NODE) THEN
          INDJP1 = -2
          RETURN
       END IF
       POINTR = ZYNEXT(POINTR)
       IF(POINTR .GT. 0) GO TO 10
C Can't go next, pop until next is possible or return to NODE is complete.
         POINTR = POP(STACK)
       IF(POINTR .EQ. -1 .OR. POINTR .EQ. NODE) THEN
          INDJP1 = -2
          RETURN
       END IF
20       CONTINUE
       POINTR = ZYNEXT(POINTR)
       IF(POINTR .GT. 0) THEN
          GO TO 10
       ELSE
          POINTR = POP(STACK)
          IF(POINTR .EQ. -1 .OR. POINTR .EQ. NODE) THEN
             INDJP1 = -2
             RETURN
          END IF
          GO TO 20
      END IF
      END
C---------------------------------------------------------------
C   I N D J M 1
C
      INTEGER FUNCTION INDJM1(NODE,NAME,CONST,JM0)
C Return 'yes' or 'no' according to whether, in the subtree rooted
C at NODE, every index of every array element is of form NAME or
C NAME - KON where val(KON) is any of val(CONST),val(CONST)-1,...,1.
C (KON and CONST are represented as strings.) If any index is of the
C form NAME, then return JM0 as .TRUE., otherwise JM0 is returned
C as .FALSE.
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
      INTEGER NODE,NAME(*),CONST(*),POINTR,TYPE,INDPTR,NPIPTR,
     +          STACK(500),KON(4),
     +          NUM1,VALKON,VALCNS,JSTR(10),PLUS,JPMC
 
      LOGICAL JM0
      SAVE
      INTEGER ZYROOT, NODETP, ZYDOWN, ZYNEXT, ZYUP, PUSH, POP,
     +          EQUAL,CTOI
 
      EXTERNAL ZYINPT, ZYROOT, ZPTINT, NODETP, ZYDOWN, ZCHOUT,
     +           ZYNEXT, ZYUP, PUSH, POP, ZYGTSY,
     +           ZYGTST, ZPTMES, EQUAL, SCOPY, GETSTR,CTOI
 
      STACK(1) = -1
      JM0 = .FALSE.
 
      POINTR = NODE
10    CONTINUE
      TYPE = NODETP(POINTR)
      IF(TYPE .EQ. 104) THEN
        INDPTR = ZYNEXT(ZYDOWN(POINTR))
C INDPTR is the node of an index. Remove parentheses.
50      NPIPTR = INDPTR
30      CONTINUE
          IF (NODETP(NPIPTR) .EQ. 101) THEN
             NPIPTR = ZYDOWN(NPIPTR)
             GO TO 30
          END IF
 
          IF (JPMC(NPIPTR,JSTR,KON,PLUS) .EQ. -3) THEN
             INDJM1 = -3
             RETURN
          END IF
 
C The index is of form J, J+c, or J-c.
          IF (PLUS .EQ. 1) THEN
             INDJM1 = -3
             RETURN
          END IF
 
C The index is of form J or J - c.  Is J = NAME?
          IF (EQUAL(JSTR,NAME) .EQ. -3) THEN
             INDJM1 = -3
             RETURN
          END IF
 
          IF (PLUS .EQ. 0) THEN
             JM0 = .TRUE.
             GO TO 40
          END IF
 
C The index is of form J - c.  Is c = CONST or CONST-1 or ... or 1?
          NUM1 = 1
          VALKON = CTOI(KON,NUM1)
          NUM1 = 1
          VALCNS = CTOI(CONST,NUM1)
          IF ((VALKON .GT. VALCNS) .OR. (VALKON .LT. 1)) THEN
             INDJM1 = -3
             RETURN
          END IF
 
40          CONTINUE
 
C The index is of form NAME - KON.  Go on to the next index.
          INDPTR = ZYNEXT(INDPTR)
          IF (INDPTR .GT. 0) GO TO 50
       END IF
       IF(PUSH(POINTR,STACK) .EQ. -1)CALL ERROR('Stack Full.',2)
       POINTR = ZYDOWN(POINTR)
C If POINTR > 0, node is not a leaf.
       IF(POINTR .GT. 0) GO TO 10
C Node is a leaf.
C Can't go down, try next unless we are at NODE.
       POINTR = POP(STACK)
       IF(POINTR .EQ. NODE) THEN
          INDJM1 = -2
          RETURN
       END IF
       POINTR = ZYNEXT(POINTR)
       IF(POINTR .GT. 0) GO TO 10
C Can't go next, pop until next is possible or return to NODE is complete.
         POINTR = POP(STACK)
       IF(POINTR .EQ. -1 .OR. POINTR .EQ. NODE) THEN
          INDJM1 = -2
          RETURN
       END IF
20       CONTINUE
       POINTR = ZYNEXT(POINTR)
       IF(POINTR .GT. 0) THEN
          GO TO 10
       ELSE
          POINTR = POP(STACK)
          IF(POINTR .EQ. -1 .OR. POINTR .EQ. NODE) THEN
             INDJM1 = -2
             RETURN
          END IF
          GO TO 20
       END IF
       END
C -----------------------------------------------------------------
C   I N D J P K
C
      INTEGER FUNCTION INDJPK(NODE,NAME)
C Return 'yes' or 'no' according to whether, in the subtree rooted
C at NODE, every index of every array element is of form NAME or
C NAME + KON where val(KON) .gt. 0.
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
      INTEGER NODE,NAME(*), JPMC
      SAVE
      INTEGER POINTR,TYPE,INDPTR,NPIPTR,STACK(500),KON(4),
     +          JSTR(10),PLUS
 
       INTEGER ZYROOT, NODETP, ZYDOWN, ZYNEXT, ZYUP, PUSH, POP,
     +          EQUAL,CTOI
 
       EXTERNAL ZYINPT, ZYROOT, ZPTINT, NODETP, ZYDOWN, ZCHOUT,
     +           ZYNEXT, ZYUP, PUSH, POP, ZYGTSY,
     +           ZYGTST, ZPTMES, EQUAL, SCOPY, GETSTR,CTOI
 
       STACK(1) = -1
 
       POINTR = NODE
10       CONTINUE
       TYPE = NODETP(POINTR)
       IF(TYPE .EQ. 104) THEN
          INDPTR = ZYNEXT(ZYDOWN(POINTR))
C INDPTR is the node of an index. Remove parentheses.
50          NPIPTR = INDPTR
30          CONTINUE
          IF (NODETP(NPIPTR) .EQ. 101) THEN
             NPIPTR = ZYDOWN(NPIPTR)
             GO TO 30
          END IF
 
          IF (JPMC(NPIPTR,JSTR,KON,PLUS) .EQ. -3) THEN
             INDJPK = -3
             RETURN
          END IF
 
C The index is of form J, J+c, or J-c.
          IF (PLUS .EQ. -1) THEN
             INDJPK = -3
             RETURN
          END IF
 
C The index is of form J or J + c.  Is J = NAME?
          IF (EQUAL(JSTR,NAME) .EQ. -3) THEN
             INDJPK = -3
             RETURN
          END IF
 
C The index is of form NAME + KON.  Go on to the next index.
          INDPTR = ZYNEXT(INDPTR)
          IF (INDPTR .GT. 0) GO TO 50
       END IF
       IF(PUSH(POINTR,STACK) .EQ. -1)CALL ERROR('Stack Full.',2)
       POINTR = ZYDOWN(POINTR)
C If POINTR > 0, node is not a leaf.
       IF(POINTR .GT. 0) GO TO 10
C Node is a leaf.
C Can't go down, try next unless we are at NODE.
       POINTR = POP(STACK)
       IF(POINTR .EQ. NODE) THEN
          INDJPK = -2
          RETURN
       END IF
       POINTR = ZYNEXT(POINTR)
       IF(POINTR .GT. 0) GO TO 10
C Can't go next, pop until next is possible or return to NODE is complete.
         POINTR = POP(STACK)
       IF(POINTR .EQ. -1 .OR. POINTR .EQ. NODE) THEN
          INDJPK = -2
          RETURN
       END IF
20       CONTINUE
       POINTR = ZYNEXT(POINTR)
       IF(POINTR .GT. 0) THEN
          GO TO 10
       ELSE
          POINTR = POP(STACK)
          IF(POINTR .EQ. -1 .OR. POINTR .EQ. NODE) THEN
             INDJPK = -2
             RETURN
          END IF
          GO TO 20
       END IF
       END
C-----------------------   COMDEP.MAC
C ---------------------------------------------------------------
C      C O M D E P - Output comments about violation of the
C                    permutability condition checked by CHKDOP.
C
C For any value of NUM output comment:
C "C *** See ISTCD Documentation For Definition Of PEQ Conditions ***"
C (only one such comment per DO sequence)
C
C If NUM = 1, reset PRNTED to .FALSE.
C
C If NUM = 2, output comment:
C "C     >>> Condition PEQ-A fails <<<"
C
C If NUM = 3, output comment:
C "C     >>> Condition PEQ-B fails for array [NAME] <<<"
C
C If NUM = 33, output comment:
C "C     >>> Condition PEQ-B fails <<<"
C
C If NUM = 4, output comment:
C "C     >>> Condition PEQ-C fails for array [NAME] <<<"
C
C If NUM = 5, output comment:
C "C *** PEQ conditions are satisfied ***"
 
       SUBROUTINE COMDEP(NUM,NAME)
 
       INTEGER NUM,NAME(7)
       LOGICAL PRNTED
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
       INTEGER COM1(66),COM2(35),COM3(52),COM33(35),
     +          COM4(52),COM5(38)
 
       INTEGER LENGTH, JJ
 
       EXTERNAL LENGTH,ZTOKWR
 
       SAVE
C "C *** See ISTCD documentation for definition of PEQ conditions ***"
       DATA COM1/67,42,42,42,32,
     +            83,101,101,32,73,83,84,67,68,
     +            32,100,111,99,117,109,101,110,116,97,
     +            116,105,111,110,32,102,111,114,32,
     +            100,101,102,105,110,105,116,105,111,110,
     +            32,111,102,32,80,69,81,32,99,
     +            111,110,100,105,116,105,111,110,115,
     +            32,42,42,42,129/
 
C "C     >>> Condition PEQ-A fails <<<"
       DATA COM2/67,
     +        32,32,32,32,62,62,62,32,
     +        67,111,110,100,105,116,105,111,110,32,
     +        80,69,81,45,65,32,102,97,105,108,
     +        115,32,60,60,60,129/
 
C "C     >>> Condition PEQ-B fails for array "
       DATA (COM3(JJ),JJ=1,41)/67,
     +        32,32,32,32,62,62,62,32,
     +        67,111,110,100,105,116,105,111,110,32,
     +        80,69,81,45,66,32,102,97,105,108,
     +        115,32,102,111,114,32,97,114,114,97,121,
     +        32/
 
C "C     >>> Condition PEQ-B fails <<<"
       DATA COM33/67,
     +        32,32,32,32,62,62,62,32,
     +        67,111,110,100,105,116,105,111,110,32,
     +        80,69,81,45,66,32,102,97,105,108,
     +        115,32,60,60,60,129/
 
C "C     >>> Condition PEQ-C fails for array "
       DATA (COM4(JJ),JJ=1,41)/67,
     +        32,32,32,32,62,62,62,32,
     +        67,111,110,100,105,116,105,111,110,32,
     +        80,69,81,45,67,32,102,97,105,108,
     +        115,32,102,111,114,32,97,114,114,97,121,
     +        32/
 
C "C *** PEQ conditions are satisfied ***"
       DATA COM5/67,42,42,42,32,
     +            80,69,81,32,99,111,110,100,105,
     +            116,105,111,110,115,32,97,114,101,
     +            32,115,97,116,105,115,102,105,101,100,
     +            32,42,42,42,129/
 
       DATA PRNTED /.FALSE./
 
       IF (NUM .EQ. 1) THEN
          PRNTED = .FALSE.
          RETURN
       END IF
 
        IF (.NOT. PRNTED) THEN
            CALL ZTOKWR(TCMMNT,LENGTH(COM1),COM1,TKNCHN)
          PRNTED = .TRUE.
       END IF
 
       IF (NUM .EQ. 2) THEN
C "C     >>> Condition PEQ-A fails <<<"
 
           CALL ZTOKWR(TCMMNT,LENGTH(COM2),COM2,TKNCHN)
 
       ELSE IF (NUM .EQ. 3) THEN
C "C     >>> Condition PEQ-B fails for array [NAME] <<<"
C Fill in array name.
          DO 125 JJ = 1,7
             IF (NAME(JJ) .EQ. 129) GO TO 130
             COM3(JJ+41) = NAME(JJ)
125          CONTINUE
 
130          CONTINUE
          COM3(JJ+41) = 32
          COM3(JJ+42) = 60
          COM3(JJ+43) = 60
          COM3(JJ+44) = 60
          COM3(JJ+45) = 129
 
           CALL ZTOKWR(TCMMNT,LENGTH(COM3),COM3,TKNCHN)
 
       ELSE IF (NUM .EQ. 33) THEN
C "C     >>> Condition PEQ-B fails <<<"
 
           CALL ZTOKWR(TCMMNT,LENGTH(COM33),COM33,TKNCHN)
 
       ELSE IF (NUM .EQ. 4) THEN
C "C     >>> Condition PEQ-C fails for array [NAME] <<<"
C Fill in array name.
          DO 225 JJ = 1,7
             IF (NAME(JJ) .EQ. 129) GO TO 230
             COM4(JJ+41) = NAME(JJ)
225          CONTINUE
 
230          CONTINUE
          COM4(JJ+41) = 32
          COM4(JJ+42) = 60
          COM4(JJ+43) = 60
          COM4(JJ+44) = 60
          COM4(JJ+45) = 129
 
           CALL ZTOKWR(TCMMNT,LENGTH(COM4),COM4,TKNCHN)
 
       ELSE IF (NUM. EQ. 5) THEN
 
           CALL ZTOKWR(TCMMNT,LENGTH(COM5),COM5,TKNCHN)
 
       END IF
 
       END
C-----------------------   DOPROP.MAC
C -------------------------------------------------------------------
C        D O P R O P - Obtain properties of a DO loop.
C
      SUBROUTINE DOPROP(NODE,VAR,E1,E2,E3,FIRST,LAST)
C Obtain the properties of the DO loop whose DO statement is NODE on C
C the parse tree.  The loop is assumed to end on a CONTINUE.  Return VAR:
C the DO variable,E1,E2,E3: the nodes of the three parameter expressions
C (if E3 is the default, then E3 = 0), FIRST: the node of the first
C statement in the DO range, LAST: the node of the last statement in the
C range before the terminating CONTINUE.
 
      INTEGER NODE,VAR(7),E1,E2,E3,FIRST,LAST
 
        COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
        INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
        SAVE
      INTEGER SPTR,REFNOD,VARNOD,STLBL(6),TRMLBL(6)
 
      INTEGER ZYDOWN,NODETP,ZYNEXT,EQUAL,ZYPREV
      EXTERNAL ZYDOWN,NODETP,ZYNEXT,EQUAL,GETSTR,ZYPREV
 
      IF (NODETP(NODE) .NE. 61) CALL ERROR('ISTCD: Node Is Not'
     +                              //' a DO Statement.')
 
C Get terminating label.
      REFNOD = ZYDOWN(NODE)
      IF (NODETP(REFNOD) .EQ. 115) REFNOD = ZYNEXT(REFNOD)
      CALL GETSTR(REFNOD,TRMLBL)
C Get DO variable.
      VARNOD = ZYDOWN(ZYNEXT(REFNOD))
      CALL GETSTR(VARNOD,VAR)
C Get parameter nodes.
      E1 = ZYNEXT(VARNOD)
      E2 = ZYNEXT(E1)
      E3 = ZYNEXT(E2)
C First statement in range.
      FIRST = ZYNEXT(NODE)
C Look for last statement.
      SPTR = FIRST
 
  100 CONTINUE
      REFNOD = ZYDOWN(SPTR)
      IF(REFNOD .NE. 0) THEN
        IF (NODETP(REFNOD) .EQ. 115) THEN
          CALL GETSTR(REFNOD,STLBL)
          IF (EQUAL(STLBL,TRMLBL) .EQ. -2) THEN
C Terminating CONTINUE found.
            LAST = ZYPREV(SPTR)
            RETURN
          END IF
        END IF
      END IF
 
      SPTR = ZYNEXT(SPTR)
      GO TO 100
 
      END
C-----------------------   E3EQV.MAC
C ------------------------------------------------------------------
C            E 3 E Q V - Test E3-equivalence
C
      INTEGER FUNCTION E3EQV(DONOD,E3NOD,VAR)
C If the DO statement whose node is DONOD has an E3 node
C (incrementation parameter) that is equivalent to E3NOD, and if its DO
C variable is VAR, return 'yes', otherwise return 'no'.  "Equivalence"
C means either that both incrementation parameters are default, in which
C case the "nodes" have the value 0, or that the subtrees rooted at the
C nodes are identical.  Parenthesis are removed from E3 nodes when comparing.
C
C  MODIFY TO HANDLE NODE POINTER=0 CASE PROPERLY
C
      INTEGER DONOD,E3NOD,VAR(7)
 
        COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
        INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
        SAVE
      INTEGER REFNOD,E1,E2,E3,VARNOD,VARNAM(7),TEXT(1322),
     +          CONONE(2), NE3NOD
 
      INTEGER NODETP,ZYNEXT,ZYDOWN,COMPAR,EQUAL
      EXTERNAL NODETP,ZYNEXT,ZYDOWN,COMPAR,GETSTR,EQUAL
 
      DATA CONONE/49,129/
 
C Check the type of DONOD.
      IF (NODETP(DONOD) .NE. 61) CALL ERROR('ISTCD: First'
     +      //' Argument Not Node of a DO Statement.')
 
C Get the DO variable and E3 node of the DO statement at DONOD
      REFNOD = ZYDOWN(DONOD)
      IF (NODETP(REFNOD) .EQ. 115) REFNOD = ZYNEXT(REFNOD)
      VARNOD = ZYDOWN(ZYNEXT(REFNOD))
      CALL GETSTR(VARNOD,VARNAM)
      E1 = ZYNEXT(VARNOD)
      E2 = ZYNEXT(E1)
      E3 = ZYNEXT(E2)
 
C Check for E3-equivalence.
C Compare DO variables.
      IF (EQUAL(VARNAM,VAR) .EQ. -3) THEN
         E3EQV = -3
         RETURN
      END IF
C Remove parentheses for comparing E3 nodes.
   10 CONTINUE
      IF(E3 .GT. 0) THEN
        IF (NODETP(E3) .EQ. 101) THEN
          E3 = ZYDOWN(E3)
          GO TO 10
        END IF
      ENDIF
 
      NE3NOD = E3NOD
   20 CONTINUE
      IF(NE3NOD .GT. 0) THEN
        IF (NODETP(NE3NOD) .EQ. 101) THEN
          NE3NOD = ZYDOWN(NE3NOD)
          GO TO 20
        END IF
      ENDIF
 
      IF (E3 .EQ. 0 .AND. NE3NOD .EQ. 0) THEN
C Both E3s are default
         E3EQV = -2
      ELSE IF (E3 .EQ. 0 .AND. NE3NOD .NE. 0) THEN
C Check whether E3NOD (unparenthesized) is explicitly 1.
         IF (ZYDOWN(NE3NOD) .GE. 0) THEN
C E3NOD is not a leaf and hence not 1.
            E3EQV = -3
         ELSE
            CALL GETSTR(NE3NOD,TEXT)
            IF (EQUAL(TEXT,CONONE) .EQ. -2) THEN
C Unparenthesized E3NOD is explicitly 1.
               E3EQV = -2
            ELSE
               E3EQV = -3
            END IF
         END IF
        ELSE IF (E3 .NE. 0 .AND. NE3NOD .EQ. 0) THEN
C Check whether unparenthesized E3 is explicitly 1.
         IF (ZYDOWN(E3) .GE. 0) THEN
C E3 is not a leaf and hence not 1.
            E3EQV = -3
         ELSE
            CALL GETSTR(E3,TEXT)
            IF (EQUAL(TEXT,CONONE) .EQ. -2) THEN
C E3 is explicitly 1.
               E3EQV = -2
            ELSE
               E3EQV = -3
            END IF
         END IF
      ELSE IF (COMPAR(E3,NE3NOD) .EQ. -2) THEN
C E3s are not default and are identical.
         E3EQV = -2
      ELSE
C E3s are not default and are not identical.
         E3EQV = -3
      END IF
 
      END
C-----------------------   GENOUT.MAC
C ---------------------------------------------------------------------
C        G E N O U T - Output sequence with first two DOs condensed
C                      by general algorithm.  If either E1 or E2
C                   equivalence holds (not both) then only two of
C                   the four MIN/MAX statements and only one of the
C                   two IF-THEN-ELSE blocks need be written.
C
      SUBROUTINE GENOUT(VAR,E1,E2,E3,FIRST,LAST,NRDOS,NUMF,NUML)
 
      INTEGER VAR(7),E1(50),E2(50),E3,FIRST(50),LAST(50),NRDOS,
     +          NUMF,NUML
 
        COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
        INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
      INTEGER DUMMY(2),STRMIN(4),STRMAX(4),SNUM,
     +          E0(7),EE0(7),E(7),EE(7),JUNK(7),CONONE(2),
     +          TRMLBL(6),POINTR,COM0(43),COM1(45),COM2(45),
     +          COM3(40), I
      LOGICAL E1EQV,E2EQV
 
      INTEGER LENGTH,ZYNEXT,ZYPREV
      EXTERNAL GETIL,ZTOKWR,LENGTH,COMOUT,YSTMT,ZYNEXT,CHKEQV
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C THIS IS USED BY BOTH ISTSB AND ISTCD
C
C This COMMON block contains the logical variable ITERAT which is
C set to .TRUE. when a condition is encountered that implies that
C further processing is required on the parse tree obtained from
C the token stream output from the current run.  ZQUIT is called
C with condition 'repeat' if and only if ITERAT is .TRUE.
C
C This COMMON block contains the logical variables ITERAT and CYCLE.
 
      COMMON /REPEAT/ ITERAT,CYCLE
      LOGICAL ITERAT,CYCLE
      SAVE
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
C "C*** DO loops condensed - general case ***"
      DATA COM0/67,42,42,42,32,68,79,32,108,
     +            111,111,112,115,32,99,111,110,100,101,
     +            110,115,101,100,32,45,32,103,101,110,
     +            101,114,97,108,32,99,97,115,101,32,
     +            42,42,42,129/
 
 
C "C*** DO loops condensed - E1 equivalence ***"
      DATA COM1/67,42,42,42,32,68,79,32,108,
     +            111,111,112,115,32,99,111,110,100,101,
     +            110,115,101,100,32,45,32,69,49,32,
     +            101,113,117,105,118,97,108,101,110,99,
     +            101,32,42,42,42,129/
 
C "C*** DO loops condensed - E2 equivalence ***"
      DATA COM2/67,42,42,42,32,68,79,32,108,
     +            111,111,112,115,32,99,111,110,100,101,
     +            110,115,101,100,32,45,32,69,50,32,
     +            101,113,117,105,118,97,108,101,110,99,
     +            101,32,42,42,42,129/
 
C "C*** WARNING: Possible Dependencies ***"
      DATA COM3/67,42,42,42,32,87,65,82,78,
     +            73,78,71,58,32,80,111,115,115,
     +            105,98,108,101,32,68,101,112,101,
     +            110,100,101,110,99,105,101,115,32,42,
     +            42,42,129/
 
      DATA DUMMY(1)/129/
      DATA CONONE/49,129/
      DATA STRMIN/77,73,78,129/
      DATA STRMAX/77,65,88,129/
 
      SNUM = NUMF
 
C Check for E1 or E2 equivalence of the first two DOs.
      CALL CHKEQV(E1,E2,2,E1EQV,E2EQV)
 
      IF (E1EQV) THEN
C Write a comment that loops being consensed - E1 equivalence
          CALL ZTOKWR(TCMMNT,LENGTH(COM1),COM1,TKNCHN)
          CALL ZTOKWR(TCMMNT,LENGTH(COM3),COM3,TKNCHN)
      ELSE IF (E2EQV) THEN
C Write a comment that loops being consensed - E2 equivalence
          CALL ZTOKWR(TCMMNT,LENGTH(COM2),COM2,TKNCHN)
          CALL ZTOKWR(TCMMNT,LENGTH(COM3),COM3,TKNCHN)
      ELSE
C Write a comment that loops being consensed - general case
          CALL ZTOKWR(TCMMNT,LENGTH(COM0),COM0,TKNCHN)
          CALL ZTOKWR(TCMMNT,LENGTH(COM3),COM3,TKNCHN)
      END IF
 
C Fix comment stream file descriptor
 
C Generate names for the MIN/MAX parameters.
      CALL GETIL(E0,JUNK)
      CALL GETIL(EE0,JUNK)
      CALL GETIL(E,JUNK)
      CALL GETIL(EE,JUNK)
 
C Write the MIN/MAX statements.
 
C First MIN
      IF (E1EQV) GO TO 1000
C e0
      CALL ZTOKWR(TNAME,LENGTH(E0),E0,TKNCHN)
C =
        CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C MIN
      CALL ZTOKWR(TNAME,LENGTH(STRMIN),STRMIN,TKNCHN)
C (
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
C (e1)
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
      CALL YEXPR(E1(1),TKNCHN)
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C *
        CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C (E1)
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
      CALL YEXPR(E1(2),TKNCHN)
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C *
        CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C )
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C /
        CALL ZTOKWR(TSLASH,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C end-of-statement (first MIN)
        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
1000      CONTINUE
 
C First MAX
      IF (E2EQV) GO TO 2000
C E0
      CALL ZTOKWR(TNAME,LENGTH(EE0),EE0,TKNCHN)
C =
        CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C MAX
      CALL ZTOKWR(TNAME,LENGTH(STRMAX),STRMAX,TKNCHN)
C (
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
C (e2)
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
      CALL YEXPR(E2(1),TKNCHN)
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C *
        CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C (E2)
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
      CALL YEXPR(E2(2),TKNCHN)
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C *
        CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C )
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C /
        CALL ZTOKWR(TSLASH,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C end-of-statement (first MAX)
        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
2000      CONTINUE
 
C Second MAX
      IF (E1EQV) GO TO 3000
C e
      CALL ZTOKWR(TNAME,LENGTH(E),E,TKNCHN)
C =
        CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C MAX
      CALL ZTOKWR(TNAME,LENGTH(STRMAX),STRMAX,TKNCHN)
C (
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
C (e1)
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
      CALL YEXPR(E1(1),TKNCHN)
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C *
        CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C (E1)
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
      CALL YEXPR(E1(2),TKNCHN)
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C *
        CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C )
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C /
        CALL ZTOKWR(TSLASH,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C end-of-statement (Second MAX)
        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
3000      CONTINUE
 
C Second MIN
      IF (E2EQV) GO TO 4000
C E
      CALL ZTOKWR(TNAME,LENGTH(EE),EE,TKNCHN)
C =
        CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C MIN
      CALL ZTOKWR(TNAME,LENGTH(STRMIN),STRMIN,TKNCHN)
C (
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
C (e2)
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
      CALL YEXPR(E2(1),TKNCHN)
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C *
        CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C (E2)
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
      CALL YEXPR(E2(2),TKNCHN)
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C *
        CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C )
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C /
        CALL ZTOKWR(TSLASH,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C end-of-statement (second MIN)
        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
4000      CONTINUE
 
C Write the first IF-THEN-ELSE
      IF (E1EQV) GO TO 5000
C IF
        CALL ZTOKWR(TIF,0,DUMMY(1),TKNCHN)
C (
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
C (e1)
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
      CALL YEXPR(E1(1),TKNCHN)
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C .EQ.
        CALL ZTOKWR(TEQ,0,DUMMY(1),TKNCHN)
C e0
      CALL ZTOKWR(TNAME,LENGTH(E0),E0,TKNCHN)
C )
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C THEN
        CALL ZTOKWR(TTHEN,0,DUMMY(1),TKNCHN)
C end-of-statement (first IF-THEN)
        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C Write first clean-up DO
      CALL GETIL(JUNK,TRMLBL)
C DO
        CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
C termination label reference
        CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C DO variable
        CALL ZTOKWR(TNAME,LENGTH(VAR),VAR,TKNCHN)
C =
        CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C e0
      CALL ZTOKWR(TNAME,LENGTH(E0),E0,TKNCHN)
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C e
      CALL ZTOKWR(TNAME,LENGTH(E),E,TKNCHN)
C -
        CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C end-of-statement (first clean-up DO)
        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C Write the range of the first DO.
      POINTR = FIRST(1)
100      CONTINUE
      CALL YSTMT(POINTR,TKNCHN)
      IF (POINTR .NE. LAST(1)) THEN
         POINTR = ZYNEXT(POINTR)
         GO TO 100
      END IF
 
C Write the terminating CONTINUE.
C Terminating label
      CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C CONTINUE
      CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
C end-of-statement (CONTINUE statement)
      CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C ELSE
      CALL ZTOKWR(TELSE,0,DUMMY(1),TKNCHN)
C end-of-statement (ELSE statement)
      CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C Write second clean-up DO
      CALL GETIL(JUNK,TRMLBL)
C DO
        CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
C termination label reference
        CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C DO variable
        CALL ZTOKWR(TNAME,LENGTH(VAR),VAR,TKNCHN)
C =
        CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C e0
      CALL ZTOKWR(TNAME,LENGTH(E0),E0,TKNCHN)
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C e
      CALL ZTOKWR(TNAME,LENGTH(E),E,TKNCHN)
C -
        CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C end-of-statement (second clean-up DO)
        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C Write the range of the second DO.
      POINTR = FIRST(2)
200      CONTINUE
      CALL YSTMT(POINTR,TKNCHN)
      IF (POINTR .NE. LAST(2)) THEN
         POINTR = ZYNEXT(POINTR)
         GO TO 200
      END IF
 
C Write the terminating CONTINUE.
C Terminating label
      CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C CONTINUE
      CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
C end-of-statement (CONTINUE statement)
      CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C END IF
      CALL ZTOKWR(TENDIF,0,DUMMY(1),TKNCHN)
C end-of-statement (END IF statement)
      CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
5000      CONTINUE
 
C Write the second IF-THEN-ELSE
      IF (E2EQV) GO TO 6000
C IF
        CALL ZTOKWR(TIF,0,DUMMY(1),TKNCHN)
C (
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
C (e2)
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
      CALL YEXPR(E2(1),TKNCHN)
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C .EQ.
        CALL ZTOKWR(TEQ,0,DUMMY(1),TKNCHN)
C E0
      CALL ZTOKWR(TNAME,LENGTH(EE0),EE0,TKNCHN)
C )
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C THEN
        CALL ZTOKWR(TTHEN,0,DUMMY(1),TKNCHN)
C end-of-statement (second IF-THEN)
        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C Write third clean-up DO
      CALL GETIL(JUNK,TRMLBL)
C DO
        CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
C termination label reference
        CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C DO variable
        CALL ZTOKWR(TNAME,LENGTH(VAR),VAR,TKNCHN)
C =
        CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C E
      CALL ZTOKWR(TNAME,LENGTH(EE),EE,TKNCHN)
C +
        CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C E0
      CALL ZTOKWR(TNAME,LENGTH(EE0),EE0,TKNCHN)
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C end-of-statement (third clean-up DO)
        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C Write the range of the first DO.
      POINTR = FIRST(1)
300      CONTINUE
      CALL YSTMT(POINTR,TKNCHN)
      IF (POINTR .NE. LAST(1)) THEN
         POINTR = ZYNEXT(POINTR)
         GO TO 300
      END IF
 
C Write the terminating CONTINUE.
C Terminating label
      CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C CONTINUE
      CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
C end-of-statement (CONTINUE statement)
      CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C ELSE
      CALL ZTOKWR(TELSE,0,DUMMY(1),TKNCHN)
C end-of-statement (ELSE statement)
      CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C Write fourth clean-up DO
      CALL GETIL(JUNK,TRMLBL)
C DO
        CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
C termination label reference
        CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C DO variable
        CALL ZTOKWR(TNAME,LENGTH(VAR),VAR,TKNCHN)
C =
        CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C E
      CALL ZTOKWR(TNAME,LENGTH(EE),EE,TKNCHN)
C +
        CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C E0
      CALL ZTOKWR(TNAME,LENGTH(EE0),EE0,TKNCHN)
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C end-of-statement (fourth clean-up DO)
        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C Write the range of the second DO.
      POINTR = FIRST(2)
400      CONTINUE
      CALL YSTMT(POINTR,TKNCHN)
      IF (POINTR .NE. LAST(2)) THEN
         POINTR = ZYNEXT(POINTR)
         GO TO 400
      END IF
 
C Write the terminating CONTINUE.
C Terminating label
      CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C CONTINUE
      CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
C end-of-statement (CONTINUE statement)
      CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C END IF
      CALL ZTOKWR(TENDIF,0,DUMMY(1),TKNCHN)
C end-of-statement (END IF statement)
      CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
6000      CONTINUE
 
C Write the main DO
      CALL GETIL(JUNK,TRMLBL)
C DO
        CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
C termination label reference
        CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C DO variable
        CALL ZTOKWR(TNAME,LENGTH(VAR),VAR,TKNCHN)
C =
        CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C e (=e1 in case of E1 equivalence)
      IF (E1EQV) THEN
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E1(1),TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      ELSE
         CALL ZTOKWR(TNAME,LENGTH(E),E,TKNCHN)
      END IF
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C E (=E2 in case of E2 equivalence)
      IF (E2EQV) THEN
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E2(2),TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      ELSE
         CALL ZTOKWR(TNAME,LENGTH(EE),EE,TKNCHN)
      END IF
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C 1 or (e3)
      IF (E3 .EQ. 0) THEN
         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
      ELSE
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E3,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
      END IF
C end-of-statement (main DO)
        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C Write the concatenation of the ranges of the DOs.
      DO 500 I = 1,2
         SNUM = SNUM + I
         POINTR = FIRST(I)
600         CONTINUE
         CALL YSTMT(POINTR,TKNCHN)
         SNUM = SNUM + 1
         CALL COMOUT(SNUM)
         IF (POINTR .NE. LAST(I)) THEN
            POINTR = ZYNEXT(POINTR)
            GO TO 600
         END IF
500      CONTINUE
 
C Write the terminating CONTINUE.
C Terminating label
      CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C CONTINUE
      CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
C end-of-statement (CONTINUE statement)
      CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
      SNUM = SNUM + 1
      CALL COMOUT(SNUM)
 
C Ouput the remaining DOs in the sequence
      DO 700 I = 3,NRDOS
         POINTR = FIRST(I)
         CALL YSTMT(ZYPREV(POINTR),TKNCHN)
         SNUM = SNUM + 1
         CALL COMOUT(SNUM)
800         CONTINUE
         CALL YSTMT(POINTR,TKNCHN)
         SNUM = SNUM + 1
         CALL COMOUT(SNUM)
         IF (POINTR .NE. LAST(I)) THEN
            POINTR = ZYNEXT(POINTR)
            GO TO 800
         END IF
         CALL YSTMT(ZYNEXT(POINTR),TKNCHN)
         SNUM = SNUM + 1
         CALL COMOUT(SNUM)
700      CONTINUE
 
      NUML = SNUM
C Set flag for iteration of ISTCD.
      ITERAT = .TRUE.
 
      RETURN
      END
C-----------------------   GETIL.MAC
      SUBROUTINE GETIL(DOVAR, LABEL)
C Generate a variable and a label for use by ISTCD.  Each call
C results in DOVAR being set (as an IST string) to the next member of the
C sequence Mxxxxx, Myyyyy, (where yyyyy is xxxxx decremented by 1) ...
C and LABEL being set (as an IST string) to the corresponding string
C without the leading 'M'.  The first value of xxxxx is CURLBL in COMMON
C block CLAB.
 
      INTEGER DOVAR(7),LABEL(6),RESULT(8), ZYFSYM
 
      COMMON /CLAB/ CURLBL,CURPUN,FIRST
      LOGICAL FIRST
      INTEGER CURLBL,CURPUN
 
      EXTERNAL ZITOCP
 
      SAVE
 
   10 CONTINUE
      CALL ZITOCP(CURLBL,LABEL,5,48)
      DOVAR(1) = 77
      CALL SCOPY(LABEL,1,DOVAR,2)
      DOVAR(7) = 129
 
      IF(ZYFSYM(DOVAR, CURPUN, RESULT) .NE. -1 .OR.
     +   ZYFSYM(LABEL, CURPUN, RESULT) .NE. -1) THEN
        CURLBL = CURLBL - 1
        GO TO 10
      ENDIF
 
      CURLBL = CURLBL - 1
 
      END
C-----------------------   ICOD1.MAC
C ---------------------------------------------------------------------
C          I C O D 1 - Test whether a DO and its immediately following
C                     statement match either the f01ae or f01af paradigm;
C                      if so, output the transformed (peeled) code.
C
       SUBROUTINE ICOD1(VARNOD,E1,E2,E3,FIRST,LAST,NUMF,NUML,SIC)
 
       INTEGER VARNOD,E1,E2,E3,FIRST,LAST,NUMF,NUML
       LOGICAL SIC
 
        INTEGER I
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C THIS IS USED BY BOTH ISTSB AND ISTCD
C
C This COMMON block contains the logical variable ITERAT which is
C set to .TRUE. when a condition is encountered that implies that
C further processing is required on the parse tree obtained from
C the token stream output from the current run.  ZQUIT is called
C with condition 'repeat' if and only if ITERAT is .TRUE.
C
C This COMMON block contains the logical variables ITERAT and CYCLE.
 
      COMMON /REPEAT/ ITERAT,CYCLE
      LOGICAL ITERAT,CYCLE
 
       INTEGER FOLSTM,JSTR(1322),CSTR(1322),SPTR,SNUM,
     +          COM(25),DOVAR(7),TRMLBL(6),DUMMY(2),CONONE(2),
     +          JUNK(7),CP1STR(4),NUM1,NUM4,VALC,NRDIG,PONE(1322),
     +          DNODES(200),NRDEPS,LHSFOL,LHSNOD
       LOGICAL CASE1,CASE2,JM0
 
       INTEGER LENGTH,ZYNEXT,NODETP,INDJP1,CTOI,ITOC,
     +          EQUAL,JPMC1,INDJM1,COMPAR,ZYDOWN
       EXTERNAL GETIL,YEXPR,COMOUT,LENGTH,ZTOKWR,YSTMT,
     +           ZYNEXT,CHKEQV,NODETP,GETSTR,INDJP1,
     +           CTOI,ITOC,EQUAL,JPMC1,INDJM1,COMPAR,ZYDOWN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
       SAVE
 
       DATA DUMMY(1)/129/
       DATA CONONE/49,129/
 
       DATA COM/67,42,42,42,32,80,101,101,108,
     +           105,110,103,32,97,112,112,108,105,
     +           101,100,32,42,42,42,129/
 
C E3 must be 0 in both cases.
       IF (E3 .NE. 0) THEN
          SIC = .FALSE.
          RETURN
       END IF
C The two cases are "true until proven false".  (At least one will
C be false.)
       CASE1 = .TRUE.
       CASE2 = .TRUE.
C Does xpr(E1) have form (J + c) + 1?
       IF (JPMC1(E1,JSTR,1,CSTR,1) .EQ. -3) CASE1 = .FALSE.
 
C If case 1 is false then is xpr(E1) = 1 and does xpr(E2) have form
C (J - c) -1?
 
       IF (.NOT. CASE1) THEN
          IF (ZYDOWN(E1) .GE. 0) THEN
             CASE2 = .FALSE.
          ELSE
             CALL GETSTR(E1,PONE)
             IF (EQUAL(PONE,CONONE) .NE. -2) CASE2 = .FALSE.
          END IF
          IF (CASE2) THEN
             IF (JPMC1(E2,JSTR,0,CSTR,0) .EQ. -3) CASE2 = .FALSE.
          END IF
       END IF
 
       IF ((.NOT. CASE1) .AND. (.NOT. CASE2)) THEN
          SIC = .FALSE.
          RETURN
       END IF
 
C The DO parameters satisfy one of the cases.
C Calculate c + 1 and convert it to the string CP1STR.
       NUM1 = 1
       NUM4 = 4
       VALC = CTOI(CSTR,NUM1)
       VALC = VALC + 1
       NRDIG = ITOC(VALC,CP1STR,NUM4)
 
C Is the statement immediately following the loop an assignment in which
C the lhs is an array element?
       FOLSTM = ZYNEXT(ZYNEXT(LAST))
       IF (NODETP(FOLSTM) .NE. 49) THEN
          SIC = .FALSE.
          RETURN
       END IF
 
       LHSFOL = ZYDOWN(FOLSTM)
       IF (NODETP(LHSFOL) .EQ. 115) LHSFOL = ZYNEXT(LHSFOL)
       IF (NODETP(LHSFOL) .NE. 104) THEN
          SIC = .FALSE.
          RETURN
       END IF
 
       IF (CASE1) THEN
C Does every array index in the statement following the loop have form
C JSTR + k for k = c+1,...0.
          IF (INDJP1(FOLSTM,JSTR,CP1STR) .EQ. -3) CASE1 = .FALSE.
       END IF
 
       IF (.NOT. CASE1) THEN
C Does every array index in the statement following the loop have form
C JSTR - k for k = c+1,...1.
          IF (INDJM1(FOLSTM,JSTR,CP1STR,JM0) .EQ. -3) CASE2 = .FALSE.
C We require that k > 0 for every index.
          IF (JM0) CASE2 = .FALSE.
       END IF
 
       IF ((.NOT. CASE1) .AND. (.NOT. CASE2)) THEN
          SIC = .FALSE.
          RETURN
       END IF
 
C The parameters for one of the cases are satisfied.  Is every
C statement in the range of the DO an assignment for which the
C lhs is an array element whose indices are the DO variable?
 
       SPTR = FIRST
40       CONTINUE
C Assignment?
       IF (NODETP(SPTR) .NE. 49) THEN
          SIC = .FALSE.
          RETURN
       END IF
 
C Array Element?
       LHSNOD = ZYDOWN(SPTR)
       IF (NODETP(LHSNOD) .EQ. 115) LHSNOD = ZYNEXT(LHSNOD)
       IF (NODETP(LHSNOD) .NE. 104) THEN
          SIC = .FALSE.
          RETURN
       END IF
 
C Indices are DO variable (remove parentheses before checking)?
       LHSNOD = ZYNEXT(ZYDOWN(LHSNOD))
60       CONTINUE
       IF (NODETP(LHSNOD) .EQ. 101) THEN
          LHSNOD = ZYDOWN(LHSNOD)
          GO TO 60
       END IF
       IF (COMPAR(LHSNOD,VARNOD) .NE. -2) THEN
          SIC = .FALSE.
          RETURN
       END IF
       LHSNOD = ZYNEXT(LHSNOD)
       IF (LHSNOD .NE. 0) GO TO 60
 
       IF (SPTR .NE. LAST) THEN
          SPTR = ZYNEXT(SPTR)
          GO TO 40
       END IF
 
C Is FOLSTM an assignment to a member of the dependency set of
C a statement in the DO range?
       SPTR = FIRST
50       CONTINUE
       CALL DEPSET(SPTR,DNODES,NRDEPS)
       DO 500 I=1,NRDEPS
          IF (COMPAR(LHSFOL,DNODES(I)) .EQ. -2) THEN
             SIC = .FALSE.
             RETURN
          END IF
500       CONTINUE
       IF (SPTR .NE. LAST) THEN
          SPTR = ZYNEXT(SPTR)
          GO TO 50
       END IF
 
C The conditions for one of the intervening code special cases
C (f01ae, f01af paradigms) are satisfied.  Output the transformed code.
C First output comment that peeling being applied.
       CALL ZTOKWR(TCMMNT,LENGTH(COM),COM,TKNCHN)
       IF (CASE1) THEN
          CALL ZMESS('Paradigm PAE.',2)
       ELSE IF (CASE2) THEN
          CALL ZMESS('Paradigm PAF.',2)
       END IF
       SIC = .TRUE.
       SNUM = NUMF
 
C Output the range of the DO with one of the following substituted for
C the DO variable, DOVAR:
C     xpr(JSTR) + xpr(CP1STR) if case 1 is true
C     xpr(JSTR) - xpr(CP1STR) if case 2 is true
 
 
       CALL GETSTR(VARNOD,DOVAR)
       SPTR = FIRST
 
       IF (CASE1) THEN
10          CONTINUE
           CALL UASGN(SPTR,DOVAR,JSTR,CP1STR,0,TKNCHN)
          IF (SPTR .NE. LAST) THEN
             SPTR = ZYNEXT(SPTR)
             GO TO 10
          END IF
       ELSE IF (CASE2) THEN
30          CONTINUE
           CALL UASGN(SPTR,DOVAR,JSTR,CP1STR,-1,TKNCHN)
          IF (SPTR .NE. LAST) THEN
             SPTR = ZYNEXT(SPTR)
             GO TO 30
          END IF
       END IF
 
C Output the intervening code, namely the statement following the DO.
       CALL YSTMT(FOLSTM,TKNCHN)
 
C Output the DO with the parameters set as follows:
C     E1 set to (JSTR + CP1STR) + 1 if case 1 is true
C     E2 set to (JSTR - CP1STR) - 1 if case 2 is true
 
C Generate the termination label.
       CALL GETIL(JUNK,TRMLBL)
C DO
        CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
C termination label reference
        CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C DO variable
        CALL ZTOKWR(TNAME,LENGTH(DOVAR),DOVAR,TKNCHN)
C =
        CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
       IF (CASE1) THEN
C (
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
C JSTR
           CALL ZTOKWR(TNAME,LENGTH(JSTR),JSTR,TKNCHN)
C +
           CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
C CP1STR
           CALL ZTOKWR(TDCNST,LENGTH(CP1STR),CP1STR,TKNCHN)
C )
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C +
           CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
C 1
           CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
       ELSE IF (CASE2) THEN
C 1
           CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
       END IF
C ,
           CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
       IF (CASE1) THEN
C E2
          CALL YEXPR(E2,TKNCHN)
       ELSE IF (CASE2) THEN
C (
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
C JSTR
           CALL ZTOKWR(TNAME,LENGTH(JSTR),JSTR,TKNCHN)
C -
           CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
C CP1STR
           CALL ZTOKWR(TDCNST,LENGTH(CP1STR),CP1STR,TKNCHN)
C )
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C -
           CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
C 1
           CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
       END IF
C end-of-statement (modified DO)
           CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
          SNUM = SNUM + 1
          CALL COMOUT(SNUM)
C Write the range
          SPTR = FIRST
20          CONTINUE
          CALL YSTMT(SPTR,TKNCHN)
          SNUM = SNUM + 1
          CALL COMOUT(SNUM)
          IF (SPTR .NE. LAST) THEN
             SPTR = ZYNEXT(SPTR)
             GO TO 20
          END IF
C Write the terminating CONTINUE.
C Terminating label
          CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C CONTINUE
          CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
C end-of-statement (CONTINUE statement)
          CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
          SNUM = SNUM + 1
          CALL COMOUT(SNUM)
          NUML = SNUM
C Set flag for cycling ISTSB/ISTCD.
          CYCLE = .TRUE.
 
       END
C-----------------------   ICOD2.MAC
C ---------------------------------------------------------------------
C          I C O D 2 - Test whether a DO and its immediately preceding
C                     statements satisfy the f01ad paradigm; if so,
C                      output the transformed (peeled) code.
C
       SUBROUTINE ICOD2(VARNOD,E1,E2,E3,FIRST,LAST,NUMF,NUML,
     +                   BEGBLK,NRBLK,SIC)
 
       INTEGER VARNOD,E1,E2,E3,FIRST,LAST,NUMF,NUML,BEGBLK,NRBLK
       LOGICAL SIC
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
        SAVE
        INTEGER I, J, K
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C THIS IS USED BY BOTH ISTSB AND ISTCD
C
C This COMMON block contains the logical variable ITERAT which is
C set to .TRUE. when a condition is encountered that implies that
C further processing is required on the parse tree obtained from
C the token stream output from the current run.  ZQUIT is called
C with condition 'repeat' if and only if ITERAT is .TRUE.
C
C This COMMON block contains the logical variables ITERAT and CYCLE.
 
      COMMON /REPEAT/ ITERAT,CYCLE
      LOGICAL ITERAT,CYCLE
 
       INTEGER JSTR(1322),CSTR(1322),SPTR,SNUM,TSNUM,
     +          COM(25),DOVAR(7),TRMLBL(6),DUMMY(2),CONONE(2),
     +          JUNK(7),KM1STR(4),NUM1,NUM4,VALC,NRDIG,PONE(1322),
     +          DNODES(200,10),NRDEPS(10),LHSNOD,
     +          BLKMEM,LHSMEM,NRRANG,VALK,KSTR(1322),KNOD
 
       INTEGER LENGTH,ZYNEXT,NODETP,INDJPK,CTOI,ITOC,
     +          EQUAL,JPMC1,COMPAR,ZYDOWN,ZYPREV
 
       EXTERNAL GETIL,COMOUT,LENGTH,ZTOKWR,YSTMT,
     +           ZYNEXT,NODETP,GETSTR,INDJPK,
     +           CTOI,ITOC,EQUAL,JPMC1,COMPAR,ZYDOWN,
     +           ZYPREV
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
       DATA DUMMY(1)/129/
       DATA CONONE/49,129/
 
       DATA COM/67,42,42,42,32,80,101,101,108,
     +           105,110,103,32,97,112,112,108,105,
     +           101,100,32,42,42,42,129/
 
C If there are no assignment statements preceding the DO, the paradigm
C does not match.
       IF (NRBLK .EQ. 0) THEN
          SIC = .FALSE.
          RETURN
       END IF
 
C E3 must be 0.
       IF (E3 .NE. 0) THEN
          SIC = .FALSE.
          RETURN
       END IF
 
C Is xpr(E1) = 1?
       IF (ZYDOWN(E1) .GE. 0) THEN
          SIC = .FALSE.
          RETURN
       END IF
 
       CALL GETSTR(E1,PONE)
       IF (EQUAL(PONE,CONONE) .NE. -2) THEN
          SIC = .FALSE.
          RETURN
       END IF
 
C Does xpr(E2) have form (J + c) - 1?
       IF (JPMC1(E2,JSTR,1,CSTR,0) .EQ. -3) THEN
          SIC = .FALSE.
          RETURN
       END IF
 
C The DO parameters match the paradigm.
C Calculate the value of c = VALC.
       NUM1 = 1
       VALC = CTOI(CSTR,NUM1)
 
C Determine the dependency sets of statements in the DO range.
       SPTR = FIRST
       NRRANG = 1
100       CONTINUE
       CALL DEPSET(SPTR,DNODES(1,NRRANG),NRDEPS(NRRANG))
       IF (SPTR .NE. LAST) THEN
          SPTR = ZYNEXT(SPTR)
          NRRANG = NRRANG + 1
          IF (NRRANG .GT. 10) CALL ERROR('ICOD2: Second '
     +         //'Dimension Of DNODES = Dimension Of NRDEPS '
     +         //'Is Too Small.')
          GO TO 100
       END IF
 
C Examine each statement in the block of assignment statements for
C conformance to the paradigm.
       BLKMEM = BEGBLK
       DO 80 I = 1,NRBLK
 
C Is every index in the statement of form J+k where k .ge. 0?
          IF(INDJPK(BLKMEM,JSTR) .EQ. -3) THEN
             SIC = .FALSE.
             RETURN
          END IF
 
C Is the lhs an array element (after outer parentheses are removed)?
          LHSMEM = ZYDOWN(BLKMEM)
          IF (NODETP(LHSMEM) .EQ. 115) LHSMEM = ZYNEXT(LHSMEM)
90          CONTINUE
          IF (NODETP(LHSMEM) .EQ. 101) THEN
             LHSMEM = ZYDOWN(LHSMEM)
             GO TO 90
          END IF
          IF (NODETP(LHSMEM) .NE. 104) THEN
             SIC = .FALSE.
             RETURN
          ELSE
C The lhs is an array element and we know from the previous check
C that its indices are of form J+k.  Check that there is only one index
C and evaluate k.  There are two cases: k=0 and k .gt. 0.
             KNOD = ZYNEXT(ZYDOWN(LHSMEM))
             IF (NODETP(KNOD) .EQ. 108) THEN
                IF (ZYNEXT(KNOD) .GT. 0) THEN
                   SIC = .FALSE.
                   RETURN
                END IF
                VALK = 0
             ELSE IF (NODETP(KNOD) .EQ. 95) THEN
                IF (ZYNEXT(KNOD) .GT. 0) THEN
                   SIC = .FALSE.
                   RETURN
                END IF
                KNOD = ZYNEXT(ZYDOWN(KNOD))
                CALL GETSTR(KNOD,KSTR)
                NUM1 = 1
                VALK = CTOI(KSTR,NUM1)
             ELSE
C This branch should never be taken!
                CALL ERROR('ICOD2: Internal Error 1.')
             END IF
          END IF
 
C Is k < c?
          IF (VALK .GE. VALC) THEN
             SIC = .FALSE.
             RETURN
          END IF
 
C Is the statement an assignment to a member of the dependency
C set of a statement in the DO range?
          DO 110 K = 1,NRRANG
             DO 120 J = 1,NRDEPS(K)
                IF (COMPAR(LHSMEM,DNODES(J,K)) .EQ. -2) THEN
                   SIC = .FALSE.
                   RETURN
                END IF
120             CONTINUE
110          CONTINUE
          BLKMEM = ZYNEXT(BLKMEM)
80       CONTINUE
 
C Is every statement in the range of the DO an assignment for which the
C lhs is an array element whose indices are the DO variable?
       SPTR = FIRST
40       CONTINUE
C Assignment?
       IF (NODETP(SPTR) .NE. 49) THEN
          SIC = .FALSE.
          RETURN
       END IF
 
C Array Element?
       LHSNOD = ZYDOWN(SPTR)
       IF (NODETP(LHSNOD) .EQ. 115) LHSNOD = ZYNEXT(LHSNOD)
       IF (NODETP(LHSNOD) .NE. 104) THEN
          SIC = .FALSE.
          RETURN
       END IF
 
C Each index is the DO variable (remove parentheses before checking)?
       LHSNOD = ZYNEXT(ZYDOWN(LHSNOD))
60       CONTINUE
       IF (NODETP(LHSNOD) .EQ. 101) THEN
          LHSNOD = ZYDOWN(LHSNOD)
          GO TO 60
       END IF
       IF (COMPAR(LHSNOD,VARNOD) .NE. -2) THEN
          SIC = .FALSE.
          RETURN
       END IF
       LHSNOD = ZYNEXT(LHSNOD)
       IF (LHSNOD .NE. 0) GO TO 60
 
       IF (SPTR .NE. LAST) THEN
          SPTR = ZYNEXT(SPTR)
          GO TO 40
       END IF
 
C The paradigm is satisfied.  Output the transformed code.
C First output comment that peeling being applied.
       CALL ZTOKWR(TCMMNT,LENGTH(COM),COM,TKNCHN)
       CALL ZMESS('Paradigm PAD.',2)
       SIC = .TRUE.
       SNUM = NUMF
 
C Convert the DO variable to a string.
       CALL GETSTR(VARNOD,DOVAR)
 
C Generate a new termination label for convenience.
       CALL GETIL(JUNK,TRMLBL)
 
C Output the DO statement with x(E2) changed to J - 1.
C DO
        CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
C termination label reference
        CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C DO variable
        CALL ZTOKWR(TNAME,LENGTH(DOVAR),DOVAR,TKNCHN)
C =
        CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C 1
        CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C JSTR
        CALL ZTOKWR(TNAME,LENGTH(JSTR),JSTR,TKNCHN)
C -
        CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
C 1
        CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
C end-of-statement (modified DO)
        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C Adjust the statement pointer by the number of statements in buffer.
       TSNUM = SNUM + NRBLK
       TSNUM = TSNUM + 1
       CALL COMOUT(TSNUM)
 
C Write the range
       SPTR = FIRST
20       CONTINUE
       CALL YSTMT(SPTR,TKNCHN)
       TSNUM = TSNUM + 1
       CALL COMOUT(TSNUM)
       IF (SPTR .NE. LAST) THEN
          SPTR = ZYNEXT(SPTR)
          GO TO 20
       END IF
C Write the terminating CONTINUE.
C Terminating label
       CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C CONTINUE
       CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
C end-of-statement (CONTINUE statement)
       CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
       TSNUM = TSNUM + 1
       CALL COMOUT(TSNUM)
 
C Output the assignment statements in the buffer.
       BLKMEM = BEGBLK
       DO 500 I = 1,NRBLK
           CALL YSTMT(BLKMEM,TKNCHN)
          SNUM = SNUM + 1
          CALL COMOUT(SNUM)
          BLKMEM = ZYNEXT(BLKMEM)
500       CONTINUE
 
C Output the range of the DO c times.  On the nth repetition,
C substitute J + (n-1) for the DO variable.
 
       DO 600 K = 1,VALC
C Convert the value of K-1 to the string KM1STR.
          NUM4 = 4
          NRDIG = ITOC(K-1,KM1STR,NUM4)
 
          SPTR = FIRST
10          CONTINUE
           CALL UASGN(SPTR,DOVAR,JSTR,KM1STR,0,TKNCHN)
          IF (SPTR .NE. LAST) THEN
             SPTR = ZYNEXT(SPTR)
             GO TO 10
          END IF
600       CONTINUE
 
C Set flag to repeat ISTCD.
       ITERAT = .TRUE.
 
       NUML = TSNUM
 
       END
C-----------------------   ICOD3.MAC
C ---------------------------------------------------------------------
C          I C O D 3 - Test whether a DO and its immediately following
C                     two statements are such as would be generated
C                      by the peeling in P4AJAK; i.e., following assignment
C                     statements are the result of the peeling followed
C                     by a DO satisfying the conditions of
C                     P4AJAK.  If these conditions hold, move
C                      the assignments and condense the DOs.  NXTNOD = 0
C                     if the conditions fail and no action taken; otherwise,
C                     NXTNOD is the node following the second DO.
C
       SUBROUTINE ICOD3(VARNOD,E1,E2,E3,FIRST,LAST,NUMF,NUML,NXTNOD)
 
       INTEGER VARNOD,E1,E2,E3,FIRST,LAST,NUMF,NUML,NXTNOD
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
        SAVE
        INTEGER I, J, K, INDNOD
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C THIS IS USED BY BOTH ISTSB AND ISTCD
C
C This COMMON block contains the logical variable ITERAT which is
C set to .TRUE. when a condition is encountered that implies that
C further processing is required on the parse tree obtained from
C the token stream output from the current run.  ZQUIT is called
C with condition 'repeat' if and only if ITERAT is .TRUE.
C
C This COMMON block contains the logical variables ITERAT and CYCLE.
 
      COMMON /REPEAT/ ITERAT,CYCLE
      LOGICAL ITERAT,CYCLE
 
       INTEGER SPTR,SNUM,COM(53),DOVAR1(7),TRMLBL(6),DUMMY(2),
     +          DNODES(200,10),NRDEPS(10),LHSNOD,JUNK1,JUNK2,DOVAR2(7),
     +          LHSSTM,NRRANG,DOSTM,EE1(2),EE2(2),EE3(2),
     +          FIRST2,LAST2,CONST(1322),VCONST,JSTR1(10),
     +          JSTR2(10),CSTR1(10),CSTR2(10),CONONE(2),JUNK(7),NUM1,
     +          BEGBLK,ASNSTM,NRBLK
 
       LOGICAL LOGJNK
 
       INTEGER LENGTH,ZYNEXT,NODETP,INDJP1,INDJPK,CTOI,ITOC,
     +          EQUAL,JPMC1,INDJM1,COMPAR,ZYDOWN,ZYPREV
 
       EXTERNAL GETIL,YEXPR,COMOUT,LENGTH,ZTOKWR,YSTMT,
     +           ZYNEXT,CHKEQV,NODETP,GETSTR,INDJP1,INDJPK,
     +           CTOI,ITOC,EQUAL,JPMC1,INDJM1,COMPAR,ZYDOWN,
     +           ZYPREV
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
       DATA DUMMY(1)/129/
       DATA CONONE/49,129/
 
C "C*** Intervening statements moved - DOs combined ***"
       DATA COM/67,42,42,42,32,73,110,116,101,
     +  114,118,101,110,105,110,103,32,115,116,97,
     +  116,101,109,101,110,116,115,32,109,111,118,101,
     +  100,32,45,32,68,79,115,32,99,111,
     +  109,98,105,110,101,100,32,42,42,42,129/
 
C Get the block of assignment statements following the DO.  The
C first is BEGBLK and there are NRBLK assignment statements.
       NRBLK = 0
       BEGBLK = ZYNEXT(ZYNEXT(LAST))
       ASNSTM = BEGBLK
50       CONTINUE
       IF (NODETP(ASNSTM) .EQ. 49) THEN
          NRBLK = NRBLK + 1
          ASNSTM = ZYNEXT(ASNSTM)
          GO TO 50
       END IF
 
C Is the assignment block non-null?
       IF (NRBLK .EQ. 0) THEN
          NXTNOD = 0
          RETURN
       END IF
 
C Is the statement after the last assignment a DO?
       DOSTM = ASNSTM
       IF (NODETP(DOSTM) .NE. 61) THEN
          NXTNOD = 0
          RETURN
       END IF
 
C Are the DOs E1,E2 equivalent in the sense of P4AJAK; i.e., xpr(E1)=1,
C xpr(E2) = (J-k)-1 for some k .ge. 0, E3 default?
 
       CALL DOPROP(ZYPREV(FIRST),DOVAR1,EE1(1),EE2(1),EE3(1),JUNK1,
     +              JUNK2)
       CALL DOPROP(DOSTM,DOVAR2,EE1(2),EE2(2),EE3(2),FIRST2,LAST2)
 
C xpr(E3) default for both DOs?
       IF ((EE3(1) .NE. 0) .OR. (EE3(2) .NE. 0)) THEN
          NXTNOD = 0
          RETURN
       END IF
 
C xpr(E1) = 1 for both DOs?
       DO 10 I = 1,2
          IF (NODETP(EE1(I)) .NE. 107) THEN
             NXTNOD = 0
             RETURN
          END IF
 
          CALL GETSTR(EE1(I),CONST)
          NUM1 = 1
          VCONST = CTOI(CONST,NUM1)
          IF (VCONST .NE. 1) THEN
             NXTNOD = 0
             RETURN
          END IF
10       CONTINUE
 
C Check the condition on the E2 nodes.
 
       IF (JPMC1(EE2(1),JSTR1,0,CSTR1,0) .EQ. -3) THEN
          NXTNOD = 0
          RETURN
       END IF
       IF (JPMC1(EE2(2),JSTR2,0,CSTR2,0) .EQ. -3) THEN
          NXTNOD = 0
          RETURN
       END IF
 
       IF (COMPAR(EE2(1),EE2(2)) .EQ. -3) THEN
          NXTNOD = 0
          RETURN
       END IF
 
C Determine the dependency sets of statements in the range
C of the first DO.
       SPTR = FIRST
       NRRANG = 1
100       CONTINUE
       CALL DEPSET(SPTR,DNODES(1,NRRANG),NRDEPS(NRRANG))
       IF (SPTR .NE. LAST) THEN
          SPTR = ZYNEXT(SPTR)
          NRRANG = NRRANG + 1
          IF (NRRANG .GT. 10) CALL ERROR('ICOD3: Second '
     +         //'Dimension Of DNODES = Dimension Of NRDEPS '
     +         //'Is Too Small.')
          GO TO 100
       END IF
 
C Examine each statement in the assignment block following the first DO.
 
       ASNSTM = BEGBLK
       DO 2000 I = 1,NRBLK
 
C Is every index in the statement of form J-k where 0 .le. k .le. c?
          IF(INDJM1(ASNSTM,JSTR1,CSTR1,LOGJNK) .EQ. -3) THEN
             NXTNOD = 0
             RETURN
          END IF
 
C Is the lhs an array element (after outer parentheses are removed)?
          LHSSTM = ZYDOWN(ASNSTM)
          IF (NODETP(LHSSTM) .EQ. 115) LHSSTM = ZYNEXT(LHSSTM)
90          CONTINUE
          IF (NODETP(LHSSTM) .EQ. 101) THEN
             LHSSTM = ZYDOWN(LHSSTM)
             GO TO 90
          END IF
          IF (NODETP(LHSSTM) .NE. 104) THEN
             NXTNOD = 0
             RETURN
          END IF
 
C Is the statement an assignment to a member of the dependency
C set of a statement in the DO range?
          DO 110 K = 1,NRRANG
             DO 120 J = 1,NRDEPS(K)
                IF (COMPAR(LHSSTM,DNODES(J,K)) .EQ. -2) THEN
                   NXTNOD = 0
                   RETURN
                END IF
120             CONTINUE
110          CONTINUE
 
          ASNSTM = ZYNEXT(ASNSTM)
2000       CONTINUE
 
C Is every statement in the range of the DO an assignment for which the
C lhs is an array element whose indices are the DO variable?
       SPTR = FIRST
40       CONTINUE
C Assignment?
       IF (NODETP(SPTR) .NE. 49) THEN
          NXTNOD = 0
          RETURN
       END IF
 
C Array Element?
       LHSNOD = ZYDOWN(SPTR)
       IF (NODETP(LHSNOD) .EQ. 115) LHSNOD = ZYNEXT(LHSNOD)
       IF (NODETP(LHSNOD) .NE. 104) THEN
          NXTNOD = 0
          RETURN
       END IF
 
C Each index is the DO variable (remove parentheses before checking)?
       INDNOD = ZYNEXT(ZYDOWN(LHSNOD))
60       CONTINUE
       IF (NODETP(INDNOD) .EQ. 101) THEN
          INDNOD = ZYDOWN(INDNOD)
          GO TO 60
       END IF
       IF (COMPAR(INDNOD,VARNOD) .NE. -2) THEN
          NXTNOD = 0
          RETURN
       END IF
       INDNOD = ZYNEXT(INDNOD)
       IF (INDNOD .NE. 0) GO TO 60
 
       IF (SPTR .NE. LAST) THEN
          SPTR = ZYNEXT(SPTR)
          GO TO 40
       END IF
 
C The conditions are satisfied.  Output the transformed code.
C First output comment that transformation being applied.
       CALL ZTOKWR(TCMMNT,LENGTH(COM),COM,TKNCHN)
       CALL ZMESS('Continue Paradigm PJK.',2)
       NXTNOD = ZYNEXT(ZYNEXT(LAST2))
       SNUM = NUMF
 
C Output the assignment block.
       ASNSTM = BEGBLK
       DO 2100 I = 1,NRBLK
          CALL YSTMT(ASNSTM,TKNCHN)
          ASNSTM = ZYNEXT(ASNSTM)
2100       CONTINUE
 
C Generate a new termination label for convenience.
       CALL GETIL(JUNK,TRMLBL)
 
C Output the DO statement for the condensed DO.
C DO
        CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
C termination label reference
        CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C DO variable
        CALL ZTOKWR(TNAME,LENGTH(DOVAR1),DOVAR1,TKNCHN)
C =
        CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C 1
        CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C E2
       CALL YEXPR(EE2(1),TKNCHN)
C end-of-statement (DO)
        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
       SNUM = SNUM + 1
       CALL COMOUT(SNUM)
 
C Write the range of the first DO.
       SPTR = FIRST
20       CONTINUE
       CALL YSTMT(SPTR,TKNCHN)
       SNUM = SNUM + 1
       CALL COMOUT(SNUM)
       IF (SPTR .NE. LAST) THEN
          SPTR = ZYNEXT(SPTR)
          GO TO 20
       END IF
 
       SNUM = SNUM + NRBLK + 2
 
C Write the range of the second DO.
       SPTR = FIRST2
30       CONTINUE
       CALL YSTMT(SPTR,TKNCHN)
       SNUM = SNUM + 1
       CALL COMOUT(SNUM)
       IF (SPTR .NE. LAST2) THEN
          SPTR = ZYNEXT(SPTR)
          GO TO 30
       END IF
 
C Write the terminating CONTINUE.
C Terminating label
       CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C CONTINUE
       CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
C end-of-statement (CONTINUE statement)
       CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
       SNUM = SNUM + 1
       CALL COMOUT(SNUM)
 
C Set flag to repeat ISTYP/ISTCD
       ITERAT = .TRUE.
 
       NUML = SNUM
 
       END
C-----------------------   JPMC.MAC
C ---------------------------------------------------------------------
C            J P M C - Test whether xpr(NODE) is of the form J or J+c or J-c
C                   (with outer parentheses removed) for integer c .ge. 1.
C                   Return 'yes' or 'no'. If 'yes', return J as a string
C                   (JSTR), c as a string (CSTR), and PLUS as 0,1,or -1
C                         for the cases J, J+c, J-c respectively.  CSTR is
C                         returned as dig0,eos when PLUS = 0.
C
      INTEGER FUNCTION JPMC(NODE,JSTR,CSTR,PLUS)
 
      INTEGER NODE,JSTR(*),CSTR(*),PLUS
 
      INTEGER CONZER(2),NPNOD,POSSJ,POSSC,TYPE
 
      INTEGER ZYNEXT,NODETP,ZYDOWN
      EXTERNAL ZYNEXT,NODETP,GETSTR,ZYDOWN,SCOPY
 
 
      DATA CONZER/48,129/
 
C Remove outer parentheses for comparison.
      NPNOD = NODE
10      CONTINUE
      IF (NODETP(NPNOD) .EQ. 101) THEN
         NPNOD = ZYDOWN(NPNOD)
         GO TO 10
      END IF
 
      TYPE = NODETP(NPNOD)
      IF (TYPE .EQ. 95) THEN
         PLUS = 1
      ELSE IF (TYPE .EQ. 96) THEN
         PLUS = -1
      ELSE IF (TYPE .EQ. 108) THEN
         PLUS = 0
         CALL GETSTR(NPNOD,JSTR)
         CALL SCOPY(CONZER,1,CSTR,1)
         JPMC = -2
         RETURN
      ELSE
         JPMC = -3
         RETURN
      END IF
 
C Node is of type N_PLUS or N_MINUS.
 
C J+ or J-?
      POSSJ = ZYDOWN(NPNOD)
      IF (NODETP(POSSJ) .EQ. 108) THEN
         CALL GETSTR(POSSJ,JSTR)
      ELSE
         JPMC = -3
         RETURN
      END IF
 
C J+c or J-c?
      POSSC = ZYNEXT(POSSJ)
      IF (NODETP(POSSC) .EQ. 107) THEN
         CALL GETSTR(POSSC,CSTR)
         JPMC = -2
         RETURN
      ELSE
         JPMC = -3
         RETURN
      END IF
 
      END
C-----------------------   JPMC1.MAC
C ---------------------------------------------------------------------
C         J P M C 1  - Test whether xpr(NODE) is of the form (J & c) & 1
C                   (with outer parentheses removed) where
C                   '&' is '+' or '-' as A and B are 1 or 0 respectively.
C                   Return 'yes' or 'no'. If 'yes', return
C                   J as a string and c as a string.
C                         The case J & 1 is handled as a special case and
C                         c is returned as dig0,eos.
C
      INTEGER FUNCTION JPMC1(NODE,JSTR,A,CSTR,B)
 
      INTEGER NODE,JSTR(*),A,CSTR(*),B
 
      INTEGER CONONE(2),PONE(1322),POINTR,PLUS,ATYPE,BTYPE
 
      INTEGER ZYNEXT,NODETP,ZYDOWN,EQUAL,JPMC
      EXTERNAL ZYNEXT,NODETP,GETSTR,ZYDOWN,EQUAL,JPMC
 
 
      DATA CONONE/49,129/
 
C Derive node types from A and B.
      IF (A .EQ. 1) THEN
         ATYPE = 95
      ELSE IF (A .EQ. 0) THEN
         ATYPE = 96
      ELSE
         CALL ERROR('ISTCD: Third Argument must be 0 124 1.')
      END IF
      IF (B .EQ. 1) THEN
         BTYPE = 95
      ELSE IF (B .EQ. 0) THEN
         BTYPE = 96
      ELSE
         CALL ERROR('ISTCD: Fifth Argument must be 0 124 1.')
      END IF
 
C Remove outer parentheses for comparison.
      POINTR = NODE
10      CONTINUE
      IF (NODETP(POINTR) .EQ. 101) THEN
         POINTR = ZYDOWN(POINTR)
         GO TO 10
      END IF
 
      IF (NODETP(POINTR) .NE. BTYPE) THEN
         JPMC1 = -3
         RETURN
      END IF
 
      POINTR = ZYDOWN(POINTR)
      IF (JPMC(POINTR,JSTR,CSTR,PLUS) .EQ. -3) THEN
         JPMC1 = -3
         RETURN
      END IF
 
      IF ((PLUS .EQ. 1 .AND. ATYPE .EQ. 96) .OR.
     +      (PLUS .EQ. -1 .AND. ATYPE .EQ. 95)) THEN
         JPMC1 = -3
         RETURN
      END IF
 
      POINTR = ZYNEXT(POINTR)
      IF (NODETP(POINTR) .NE. 107) THEN
         JPMC1 = -3
         RETURN
      END IF
 
      CALL GETSTR(POINTR,PONE)
      IF (EQUAL(PONE,CONONE) .NE. -2) THEN
         JPMC1 = -3
         RETURN
      END IF
 
      JPMC1 = -2
 
      END
C-----------------------   P4AJAK.MAC
C ---------------------------------------------------------------------
C             P4AJAK - Test whether a consequtive pair of DOs
C                   satisfy certain necessary conditions for
C                     the f04aj or f04ak paradigms; if so,
C                     peel the last iteration from the
C                     first DO.  The transformation will be
C                     completed by ICOD3 which, in turn, results
C                     in E1,E2 equivalence.
C
      SUBROUTINE P4AJAK(VAR,E1,E2,E3,FIRST,LAST,NRDOS,NUMF,NUML,HOLD)
 
      INTEGER VAR(7),E1(50),E2(50),E3,FIRST(50),LAST(50),NRDOS,
     +          NUMF,NUML
      LOGICAL HOLD
 
        COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
        INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
        SAVE
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C THIS IS USED BY BOTH ISTSB AND ISTCD
C
C This COMMON block contains the logical variable ITERAT which is
C set to .TRUE. when a condition is encountered that implies that
C further processing is required on the parse tree obtained from
C the token stream output from the current run.  ZQUIT is called
C with condition 'repeat' if and only if ITERAT is .TRUE.
C
C This COMMON block contains the logical variables ITERAT and CYCLE.
 
      COMMON /REPEAT/ ITERAT,CYCLE
      LOGICAL ITERAT,CYCLE
 
      INTEGER I,TRMLBL(6),DUMMY(2),SNUM,POINTR,JUNK(7),
     +          CONST(1322),VCONST,NPE2(2),COM(25),
     +          NUM1,CONONE(2),JSTR1(10),JSTR2(10),CSTR1(10),
     +          CSTR2(10),VAL1,VAL2
 
      INTEGER LENGTH,ZYNEXT,CTOI,NODETP,ZYDOWN,ZYPREV,
     +          JPMC1,EQUAL,ITOC
 
      EXTERNAL GETIL,YEXPR,COMOUT,LENGTH,ZTOKWR,YSTMT,
     +           ZYNEXT,CHKEQV,CTOI,NODETP,GETSTR,ZYDOWN,ZYPREV,
     +           JPMC1,EQUAL,UASGN,ITOC
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
C "C*** Peeling Applied ***"
      DATA COM/67,42,42,42,32,80,101,101,108,
     +           105,110,103,32,97,112,112,108,105,
     +           101,100,32,42,42,42,129/
 
      DATA DUMMY(1)/129/
      DATA CONONE/49,129/
      SNUM = NUMF
 
C Test the first two DOs in the sequence for a set of necessary
C conditions associated with the f04aj,f04ak paradigm, namely, The two
C DOs must have xpr(E3) default or 1, xpr(E1)=1, and the first and second
C xpr(E2)s must be of form
C
C            (J-c1)-1, (J-c2)-1 where c2 = c1+1.
C
C for some J where where c1,c2 .ge. 0.  If c1=0, the forms are
C
C            J-1,(J-1)-1.
C Finally, every statement in the range of the first DO must be an
C assignment.
 
C HOLD will be set to .TRUE. if the conditions hold.
      HOLD = .FALSE.
 
C xpr(E3) default or 1?
      IF (E3 .NE. 0) THEN
         IF (NODETP(E3) .NE. 107) THEN
            HOLD = .FALSE.
            RETURN
         END IF
 
         CALL GETSTR(E3,CONST)
         NUM1 = 1
         VCONST = CTOI(CONST,NUM1)
         IF (VCONST .NE. 1) THEN
            HOLD = .FALSE.
            RETURN
         END IF
      END IF
 
C xpr(E1) = 1 for both DOs?
      DO 10 I = 1,2
         IF (NODETP(E1(I)) .NE. 107) THEN
            HOLD = .FALSE.
            RETURN
         END IF
 
         CALL GETSTR(E1(I),CONST)
         NUM1 = 1
         VCONST = CTOI(CONST,NUM1)
         IF (VCONST .NE. 1) THEN
            HOLD = .FALSE.
            RETURN
         END IF
10      CONTINUE
 
C Check the condition on the E2 nodes.  Remove outer parenthesis
C for comparison.
      DO 400 I=1,2
         NPE2(I) = E2(I)
1200         CONTINUE
         IF (NODETP(NPE2(I)) .EQ. 101) THEN
            NPE2(I) = ZYDOWN(NPE2(I))
            GO TO 1200
         END IF
400      CONTINUE
 
      IF (JPMC1(NPE2(1),JSTR1,0,CSTR1,0) .EQ. -3) THEN
         HOLD = .FALSE.
         RETURN
      END IF
      IF (JPMC1(NPE2(2),JSTR2,0,CSTR2,0) .EQ. -3) THEN
         HOLD = .FALSE.
         RETURN
      END IF
 
C Same J for both DOs?
      IF (EQUAL(JSTR1,JSTR2) .EQ. -3) THEN
         HOLD = .FALSE.
         RETURN
      END IF
 
C c2 = c1+1?
      NUM1 = 1
      VAL1 = CTOI(CSTR1,NUM1)
      NUM1 = 1
      VAL2 = CTOI(CSTR2,NUM1)
      IF (VAL2 .NE. (VAL1+1)) THEN
         HOLD = .FALSE.
         RETURN
      END IF
 
C Every statement in the range of the first DO an assignment?
      POINTR = FIRST(1)
30      CONTINUE
      IF (NODETP(POINTR) .NE. 49) THEN
         HOLD = .FALSE.
         RETURN
      END IF
      IF (POINTR .NE. LAST(1)) THEN
         POINTR = ZYNEXT(POINTR)
         GO TO 30
      END IF
 
C Conditions are met.  Peel the last iteration of the first DO to the
C tail of the DO resulting in intervening code.  Output the remaining DOs
C in the sequence unchanged.  This sets up the modified first DO and the
C immediately following statement for action by ICOD3 and then by PDOSEQ
C (E1,E2 equivalence).
      HOLD = .TRUE.
      CALL ZMESS(' Applying paradigm PJK.',2)
 
C Output comment that peeling being applied.
      CALL ZTOKWR(TCMMNT,LENGTH(COM),COM,TKNCHN)
 
 
C Output the DO statement with (J-c1)-1 replaced by (J-c2)-1.
 
      CALL GETIL(JUNK,TRMLBL)
C DO
        CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
C termination label reference
        CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C DO variable
        CALL ZTOKWR(TNAME,LENGTH(VAR),VAR,TKNCHN)
C =
        CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C 1
        CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C (
        CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
C JSTR1
        CALL ZTOKWR(TNAME,LENGTH(JSTR1),JSTR1,TKNCHN)
C -
        CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
C CSTR2
        CALL ZTOKWR(TDCNST,LENGTH(CSTR2),CSTR2,TKNCHN)
C )
        CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C -
        CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
C 1
        CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
C end-of-statement (DO)
        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
      SNUM = SNUM + 1
      CALL COMOUT(SNUM)
 
C Write the range of the first DO.
      POINTR = FIRST(1)
700      CONTINUE
      CALL YSTMT(POINTR,TKNCHN)
      SNUM = SNUM + 1
      CALL COMOUT(SNUM)
      IF (POINTR .NE. LAST(1)) THEN
         POINTR = ZYNEXT(POINTR)
         GO TO 700
      END IF
 
C Write the terminating CONTINUE.
C Terminating label
      CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C CONTINUE
      CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
C end-of-statement (CONTINUE statement)
      CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
      SNUM = SNUM + 1
      CALL COMOUT(SNUM)
 
C Output the range of the first DO with (J-c1)-1 = J-c2 substituted
C for the DO variable.
      POINTR = FIRST(1)
20      CONTINUE
        CALL UASGN(POINTR,VAR,JSTR1,CSTR2,-1,TKNCHN)
      IF (POINTR .NE. LAST(1)) THEN
         POINTR = ZYNEXT(POINTR)
         GO TO 20
      END IF
 
C Output the remaining DOs in the sequence.
      DO 800 I = 2,NRDOS
         POINTR = FIRST(I)
         CALL YSTMT(ZYPREV(POINTR),TKNCHN)
         SNUM = SNUM + 1
         CALL COMOUT(SNUM)
900         CONTINUE
         CALL YSTMT(POINTR,TKNCHN)
         SNUM = SNUM + 1
         CALL COMOUT(SNUM)
         IF (POINTR .NE. LAST(I)) THEN
            POINTR = ZYNEXT(POINTR)
            GO TO 900
         END IF
         CALL YSTMT(ZYNEXT(POINTR),TKNCHN)
         SNUM = SNUM + 1
         CALL COMOUT(SNUM)
800     CONTINUE
 
      NUML = SNUM
 
C Set flag for interation of ISTCD.
      ITERAT = .TRUE.
 
      END
C-----------------------   PDOSEQ.MAC
C ---------------------------------------------------------------------
C        P D O S E Q - Process DO sequence
C
       SUBROUTINE PDOSEQ(VAR,E1,E2,E3,FIRST,LAST,NRDOS,NUMF,NUML,
     +                    LSTOUT)
 
       INTEGER VAR(7),E1(50),E2(50),E3,FIRST(50),LAST(50),NRDOS,
     +          NUMF,NUML,LSTOUT
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
        SAVE
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C THIS IS USED BY BOTH ISTSB AND ISTCD
C
C This COMMON block contains the logical variable ITERAT which is
C set to .TRUE. when a condition is encountered that implies that
C further processing is required on the parse tree obtained from
C the token stream output from the current run.  ZQUIT is called
C with condition 'repeat' if and only if ITERAT is .TRUE.
C
C This COMMON block contains the logical variables ITERAT and CYCLE.
 
      COMMON /REPEAT/ ITERAT,CYCLE
      LOGICAL ITERAT,CYCLE
 
       INTEGER I,TRMLBL(6),DUMMY(2),SNUM,POINTR,JUNK(7),
     +          CONST(1322),VCONST,NPE1(2),COM1(52),
     +          COM2(28),NUM1,CONONE(2),JSTR1(10),JSTR2(10),CSTR1(10),
     +          CSTR2(10),VAL1,VAL2,ADDSTR(10),VALADD,NUM4,NRDIGS,JUNK1,
     +          COM3(63),COM4(63),COM5(67)
 
       LOGICAL E1EQV,E2EQV,POSCON,HOLD
 
       INTEGER LENGTH,ZYNEXT,CTOI,NODETP,ZYDOWN,ZYPREV,ITOC,
     +          JPMC1,EQUAL,CHKDOP
 
       EXTERNAL GETIL,YEXPR,COMOUT,LENGTH,ZTOKWR,YSTMT,
     +           ZYNEXT,CHKEQV,CTOI,NODETP,GETSTR,ZYDOWN,ZYPREV,ITOC,
     +           JPMC1,EQUAL,UASGN,P4AJAK,CHKDOP
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
C "C*** DO loops condensed - E1 and E2 equivalence ***"
       DATA COM1/67,42,42,42,32,68,79,32,108,
     +            111,111,112,115,32,99,111,110,100,101,
     +            110,115,101,100,32,45,32,69,49,
     +            32,97,110,100,32,69,50,32,101,
     +            113,117,105,118,97,108,101,110,99,
     +            101,32,42,42,42,129/
 
C "C*** DO loops condensed ***"
       DATA COM2/67,42,42,42,32,68,79,32,108,
     +            111,111,112,115,32,99,111,110,100,101,
     +            110,115,101,100,32,42,42,42,129/
 
C "C*** WARNING: There should be no assignment statements between"
       DATA COM3/67,42,42,42,32,
     +            87,65,82,78,73,78,71,58,32,
     +            84,104,101,114,101,32,115,104,111,117,
     +            108,100,32,98,101,32,110,111,32,
     +            97,115,115,105,103,110,109,101,110,116,
     +            32,115,116,97,116,101,109,101,110,116,
     +            115,32,98,101,116,119,101,101,110,129/
 
C "C             above CONTINUE and first comment line of +'s ***"
       DATA COM4/67,32,32,32,32,32,32,
     +            32,32,32,32,32,32,32,
     +            97,98,111,118,101,32,67,79,78,84,
     +            73,78,85,69,32,97,110,100,32,
     +            102,105,114,115,116,32,99,111,109,109,
     +            101,110,116,32,108,105,110,101,32,
     +            111,102,32,43,39,115,32,42,
     +            42,42,129/
 
C "C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++"
       DATA COM5/67,43,43,43,43,43,
     +            43,43,43,43,43,43,43,43,43,43,
     +            43,43,43,43,43,43,43,43,43,43,
     +            43,43,43,43,43,43,43,43,43,43,
     +            43,43,43,43,43,43,43,43,43,43,
     +            43,43,43,43,43,43,43,43,43,43,
     +            43,43,43,43,43,43,43,43,43,43,
     +            129/
 
       DATA DUMMY(1)/129/
       DATA CONONE/49,129/
       SNUM = NUMF
 
       CALL CHKEQV(E1,E2,NRDOS,E1EQV,E2EQV)
       IF (E1EQV .AND. E2EQV) THEN
 
C The DOs are E1 and E2 equivalent.  Output comment.
          CALL ZTOKWR(TCMMNT,LENGTH(COM1),COM1,TKNCHN)
          CALL ZMESS('Paradigm PEQ.',2)
 
C Check the permutability condition. (Warnings may be issued as
C comments.)
          JUNK1 = CHKDOP(VAR,FIRST,LAST,NRDOS)
 
C The DO equivalent to the sequence has parameters E1,E2,E3 and its
C range is the concatenation of the ranges.  Write the equivalent DO.
 
C Generate the termination label.
          CALL GETIL(JUNK,TRMLBL)
C DO
           CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
C termination label reference
           CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C DO variable
           CALL ZTOKWR(TNAME,LENGTH(VAR),VAR,TKNCHN)
C =
           CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C E1
          CALL YEXPR(E1(1),TKNCHN)
C ,
           CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C E2
          CALL YEXPR(E2(1),TKNCHN)
C ,E3 if incrementation parameter not default
          IF (E3 .NE. 0) THEN
              CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
             CALL YEXPR(E3,TKNCHN)
          END IF
C end-of-statement (modified DO)
           CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
          SNUM = SNUM + 1
          CALL COMOUT(SNUM)
C Write the range (concatenation of the ranges).
          DO 200 I = 1,NRDOS
             POINTR = FIRST(I)
300             CONTINUE
             CALL YSTMT(POINTR,TKNCHN)
             SNUM = SNUM + 1
             CALL COMOUT(SNUM)
             IF (POINTR .NE. LAST(I)) THEN
                POINTR = ZYNEXT(POINTR)
                GO TO 300
             END IF
200        CONTINUE
C Write the terminating CONTINUE.
C Terminating label
          CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C CONTINUE
          CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
C end-of-statement (CONTINUE statement)
          CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
          SNUM = SNUM + 1
          CALL COMOUT(SNUM)
          NUML = SNUM + 2*(NRDOS - 1)
          LSTOUT = ZYNEXT(LAST(NRDOS))
C Set flag for iteration of ISTCD.
          ITERAT = .TRUE.
          RETURN
       END IF
C The DOs are not E1 and E2 equivalent.  Test the parameters of the
C first two DOs for the f01ak,f01al paradigms defined as follows:  The
C two DOs must be (1) E2 equivalent, (2) E3 default or 1, and (3) the
C first and second E1s have either of the following two corresponding
C forms:
 
C       (J+c1)+1, (J+(c2))+1
C or       (J-c1)+1, (J-(c2))+1
 
C for some J where where c1,c2 .ge. 0 and c2 .gt. c1.  If c1=0, the forms are
 
C       J+1,(J+c2)+1
C and       J+1,(J-c2)+1.
 
C Test the first two DOs in the sequence for E2 equivalence.
       CALL CHKEQV(E1,E2,2,E1EQV,E2EQV)
       IF (.NOT. E2EQV) GO TO 100
C The first two DOs are E2 equivalent.
       IF (E3 .NE. 0) THEN
          IF (NODETP(E3) .NE. 107) GO TO 100
          CALL GETSTR(E3,CONST)
          NUM1 = 1
          VCONST = CTOI(CONST,NUM1)
          IF (VCONST .NE. 1) GO TO 100
       END IF
C E3 is default or 1. Check the condition on the E1 nodes.
C Remove outer parenthesis for comparison.
       DO 400 I=1,2
          NPE1(I) = E1(I)
1200          CONTINUE
          IF (NODETP(NPE1(I)) .EQ. 101) THEN
             NPE1(I) = ZYDOWN(NPE1(I))
             GO TO 1200
          END IF
400       CONTINUE
 
       IF (JPMC1(NPE1(1),JSTR1,1,CSTR1,1) .EQ. -3) THEN
          POSCON = .FALSE.
          GO TO 2000
       END IF
       IF (JPMC1(NPE1(2),JSTR2,1,CSTR2,1) .EQ. -3) THEN
          POSCON = .FALSE.
          GO TO 2000
       END IF
 
       IF (EQUAL(JSTR1,JSTR2) .EQ. -3) THEN
          POSCON = .FALSE.
          GO TO 2000
       END IF
 
       NUM1 = 1
       VAL1 = CTOI(CSTR1,NUM1)
       NUM1 = 1
       VAL2 = CTOI(CSTR2,NUM1)
       IF (VAL2 .LE. VAL1) THEN
          POSCON = .FALSE.
          GO TO 2000
       END IF
 
       POSCON = .TRUE.
       GO TO 2100
 
2000       CONTINUE
       IF (JPMC1(NPE1(1),JSTR1,0,CSTR1,1) .EQ. -3) GO TO 100
 
       IF (JPMC1(NPE1(2),JSTR2,0,CSTR2,1) .EQ. -3) GO TO 100
 
       IF (EQUAL(JSTR1,JSTR2) .EQ. -3) GO TO 100
 
       NUM1 = 1
       VAL1 = CTOI(CSTR1,NUM1)
       NUM1 = 1
       VAL2 = CTOI(CSTR2,NUM1)
       IF (VAL2 .LE. VAL1) GO TO 100
 
2100   CONTINUE
C Conditions for one of the paradigms are met.
C Output comment that condensation being applied.
       CALL ZTOKWR(TCMMNT,LENGTH(COM2),COM2,TKNCHN)
       IF (POSCON) THEN
          CALL ZMESS('Paradigm PAK.',2)
       ELSE
          CALL ZMESS('Paradigm PAL.',2)
       END IF
 
C The "clean-up" is the range of one of the DOs (depending on which case
C holds) replicated c2-c1 times with an appropriate substitution.  If the
C f01ak case holds (POSCON = .TRUE.) the transformed code sequence is
C clean-up, condensed DOs, remaining DOs.  LSTOUT is then the terminating
C statement of the last DO, i.e., ZYNEXT(LAST(NRDOS)).  In the f01al
C case, the sequence is condensed DOs, remaining DOs, any assignment
C statements following the last DO, clean-up.  LSTOUT is the last
C assignment statement in sequence output after the DO.
 
       IF (POSCON) THEN
C The range of the first DO is output with the DO variable
C replaced by J+(c1+1),...,J+(c2)
          VALADD = VAL1 + 1
          NUM4 = 4
          NRDIGS = ITOC(VALADD,ADDSTR,NUM4)
2300          CONTINUE
          POINTR = FIRST(1)
1100          CONTINUE
          CALL UASGN(POINTR,VAR,JSTR1,ADDSTR,0,TKNCHN)
          IF (POINTR .NE. LAST(1)) THEN
             POINTR = ZYNEXT(POINTR)
             GO TO 1100
          END IF
          IF (VALADD .NE. VAL2) THEN
             VALADD = VALADD + 1
             NUM4 = 4
             NRDIGS = ITOC(VALADD,ADDSTR,NUM4)
             GO TO 2300
          END IF
       END IF
 
C Output the DO statement.
 
       CALL GETIL(JUNK,TRMLBL)
C DO
        CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
C termination label reference
        CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C DO variable
        CALL ZTOKWR(TNAME,LENGTH(VAR),VAR,TKNCHN)
C =
        CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
       IF (POSCON) THEN
C (
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
C JSTR1
           CALL ZTOKWR(TNAME,LENGTH(JSTR1),JSTR1,TKNCHN)
C +
           CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
C CSTR2
           CALL ZTOKWR(TDCNST,LENGTH(CSTR2),CSTR2,TKNCHN)
C )
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C +
           CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
C 1
           CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
       ELSE
C (
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
C JSTR
           CALL ZTOKWR(TNAME,LENGTH(JSTR1),JSTR1,TKNCHN)
C -
           CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
C CSTR1
           CALL ZTOKWR(TDCNST,LENGTH(CSTR1),CSTR1,TKNCHN)
C )
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C +
           CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
C 1
           CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
       END IF
C ,
        CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C xpr(E2(1))
       CALL YEXPR(E2(1),TKNCHN)
C end-of-statement (DO)
        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C Write the concatenation of the ranges of the DOs.
       DO 600 I = 1,2
          SNUM = SNUM + I
          POINTR = FIRST(I)
700          CONTINUE
          CALL YSTMT(POINTR,TKNCHN)
          SNUM = SNUM + 1
          CALL COMOUT(SNUM)
          IF (POINTR .NE. LAST(I)) THEN
             POINTR = ZYNEXT(POINTR)
             GO TO 700
          END IF
600       CONTINUE
C Write the terminating CONTINUE.
C Terminating label
       CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
C CONTINUE
       CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
C end-of-statement (CONTINUE statement)
       CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
       SNUM = SNUM + 1
       CALL COMOUT(SNUM)
C Output the remaining DOs in the sequence.
       DO 800 I = 3,NRDOS
          POINTR = FIRST(I)
          CALL YSTMT(ZYPREV(POINTR),TKNCHN)
          SNUM = SNUM + 1
          CALL COMOUT(SNUM)
900          CONTINUE
          CALL YSTMT(POINTR,TKNCHN)
          SNUM = SNUM + 1
          CALL COMOUT(SNUM)
          IF (POINTR .NE. LAST(I)) THEN
             POINTR = ZYNEXT(POINTR)
             GO TO 900
          END IF
          CALL YSTMT(ZYNEXT(POINTR),TKNCHN)
          SNUM = SNUM + 1
          CALL COMOUT(SNUM)
800     CONTINUE
 
       IF (POSCON) THEN
          LSTOUT = ZYNEXT(LAST(NRDOS))
       ELSE
C f01al paradigm is matched.  Output a comment line of +'s and a
C warning, followed by the assignment sequence that trails the last DO.
          CALL ZTOKWR(TCMMNT,LENGTH(COM5),COM5,TKNCHN)
          CALL ZTOKWR(TCMMNT,LENGTH(COM3),COM3,TKNCHN)
          CALL ZTOKWR(TCMMNT,LENGTH(COM4),COM4,TKNCHN)
 
          POINTR = ZYNEXT(ZYNEXT(LAST(NRDOS)))
3000          CONTINUE
          IF (NODETP(POINTR) .EQ. 49) THEN
             CALL YSTMT(POINTR,TKNCHN)
             SNUM = SNUM + 1
             CALL COMOUT(SNUM)
             POINTR = ZYNEXT(POINTR)
             GO TO 3000
          ELSE
C Assignments following the last DO have been output.
             LSTOUT = ZYPREV(POINTR)
 
C The range of the second DO is output with the DO variable
C replaced by J-(c2-1),...J-c1.
 
             VALADD = VAL2 - 1
             NUM4 = 4
             NRDIGS = ITOC(VALADD,ADDSTR,NUM4)
2400             CONTINUE
             POINTR = FIRST(2)
500             CONTINUE
             CALL UASGN(POINTR,VAR,JSTR1,ADDSTR,-1,TKNCHN)
             IF (POINTR .NE. LAST(2)) THEN
                POINTR = ZYNEXT(POINTR)
                GO TO 500
             END IF
             IF (VALADD .NE. VAL1) THEN
                VALADD = VALADD - 1
                NUM4 = 4
                NRDIGS = ITOC(VALADD,ADDSTR,NUM4)
                GO TO 2400
             END IF
          END IF
       END IF
 
       NUML = SNUM
 
C Set flag for interation of ISTCD.
       ITERAT = .TRUE.
       RETURN
 
100       CONTINUE
       LSTOUT = ZYNEXT(LAST(NRDOS))
 
C At least one condition for f01al,f01ak paradigms is violated.
C Check conditions for the f04aj,f04ak paradigm.  If the necessary
C conditions hold, peel as described in comments in P4AJAK.
       HOLD = .FALSE.
       CALL P4AJAK(VAR,E1,E2,E3,FIRST,LAST,NRDOS,SNUM,NUML,HOLD)
       IF (HOLD) THEN
          RETURN
       ELSE
C Invoke the general case.
          CALL ZMESS('General Case Invoked.',2)
          CALL GENOUT(VAR,E1,E2,E3,FIRST,LAST,NRDOS,SNUM,NUML)
       END IF
 
       END
C-----------------------   PROPU.MAC
C ----------------------------------------------------------------------
C
C       P R O P U   -   Process Program-Unit
C
 
        SUBROUTINE PROPU(PUROOT)
        INTEGER PUROOT
 
        INTEGER SPTR,DOPTR,SNUM,DOVAR(7),E1(50),E2(50),E3,FIRST(50),
     +          LAST(50),TYPE,NUMF,NUML,NRDOS,REFNOD,VARNOD,ASNBUF(200),
     +          NRAB,LSTOUT
      LOGICAL SIC
 
        COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
        INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
        SAVE
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C THIS IS USED BY BOTH ISTSB AND ISTCD
C
C This COMMON block contains the logical variable ITERAT which is
C set to .TRUE. when a condition is encountered that implies that
C further processing is required on the parse tree obtained from
C the token stream output from the current run.  ZQUIT is called
C with condition 'repeat' if and only if ITERAT is .TRUE.
C
C This COMMON block contains the logical variables ITERAT and CYCLE.
 
      COMMON /REPEAT/ ITERAT,CYCLE
      LOGICAL ITERAT,CYCLE
 
        INTEGER ZYDOWN,ZYNEXT,LENGTH,NODETP,COMPAR,E3EQV,I,NXTNOD
        EXTERNAL ZYDOWN,ZYNEXT,LENGTH,ZTOKWR,NODETP,DOPROP,PDOSEQ,
     +           COMPAR,YSTMT,E3EQV,ICOD1,ICOD2,ICOD3
 
        SAVE
 
        DATA SNUM/1/
 
        SPTR=ZYDOWN(PUROOT)
      NRAB = 0
 
100      CONTINUE
      TYPE = NODETP(SPTR)
      DOPTR = SPTR
      NRDOS = 0
 
C If the statement is a DO, get its properties.
      IF (TYPE .EQ. 61) THEN
 
C Get the DO variable node for possible use in processing the
C intervening code paradigms.
         REFNOD = ZYDOWN(DOPTR)
         IF (NODETP(REFNOD) .EQ. 115) REFNOD = ZYNEXT(REFNOD)
         VARNOD = ZYDOWN(ZYNEXT(REFNOD))
300         CONTINUE
         NRDOS = NRDOS + 1
         CALL DOPROP(DOPTR,DOVAR,E1(NRDOS),E2(NRDOS),E3,
     +                 FIRST(NRDOS),LAST(NRDOS))
         DOPTR = ZYNEXT(ZYNEXT(LAST(NRDOS)))
         IF (NODETP(DOPTR) .EQ. 61) THEN
C Another DO.  If it is E3-equivalent to the preceding DO, include
C it in the sequence.
            IF (E3EQV(DOPTR,E3,DOVAR) .EQ. -2) GO TO 300
         END IF
 
C We are at the end of the sequence of E3-equivalent DOs.
         IF (NRDOS .EQ. 1) THEN
C Only one DO in the sequence.  Look for intervening code paradigms.
            SIC = .FALSE.
            NUMF = SNUM
 
C f01ad paradigm.
            CALL ICOD2(VARNOD,E1(1),E2(1),E3,FIRST(1),LAST(1),
     +                    NUMF,NUML,ASNBUF(1),NRAB,SIC)
            IF (SIC) THEN
C Peeling for f01ad paradigm took place.  Advance the pointers
C accordingly, output the remainder of the program unit without change.
C and return.
               SNUM = NUML
               SPTR = ZYNEXT(ZYNEXT(LAST(1)))
30               CONTINUE
               CALL YSTMT(SPTR,TKNCHN)
               SNUM = SNUM + 1
               CALL COMOUT(SNUM)
               SPTR = ZYNEXT(SPTR)
               IF (SPTR .NE. 0) GO TO 30
               RETURN
            END IF
 
C f01ad paradigm did not match.  Output the assignment buffer.
            DO 500 I = 1,NRAB
                 CALL YSTMT(ASNBUF(I),TKNCHN)
               SNUM = SNUM + 1
               CALL COMOUT(SNUM)
500            CONTINUE
            NRAB = 0
 
C Check for the f04aj,f04ak pattern emitted from P4AJAK.
            NXTNOD = 0
            NUMF = SNUM
            CALL ICOD3(VARNOD,E1(1),E2(1),E3,FIRST(1),LAST(1),
     +                    NUMF,NUML,NXTNOD)
 
            IF (NXTNOD .NE. 0) THEN
C f04aj,f04ak statement movement and E1,E2 equivalence condensation
C took place.  Advance the pointers accordingly, output the remainder
C of the program unit without change and return.
               SNUM = NUML
               SPTR = NXTNOD
50               CONTINUE
               CALL YSTMT(SPTR,TKNCHN)
               SNUM = SNUM + 1
               CALL COMOUT(SNUM)
               SPTR = ZYNEXT(SPTR)
               IF (SPTR .NE. 0) GO TO 50
               RETURN
            END IF
 
C Try the f01ae,f01af paradigms.
C Note: SIC = .FALSE.
            NUMF = SNUM
            CALL ICOD1(VARNOD,E1(1),E2(1),E3,FIRST(1),LAST(1),
     +                    NUMF,NUML,SIC)
            IF (SIC) THEN
C Peeling for paradigm f01ae or f01af took place.  Advance the
C pointers accordingly and proceed.
               SNUM = NUML
               SPTR = ZYNEXT(ZYNEXT(LAST(1)))
               SNUM = SNUM + 1
               CALL COMOUT(SNUM)
            ELSE
C Intervening code paradigms do not match. Output the DO statement
C and proceed.
                 CALL YSTMT(SPTR,TKNCHN)
               SNUM = SNUM + 1
               CALL COMOUT(SNUM)
            END IF
         ELSE
C The DO sequence contains more than one member.
C Output the assignment buffer.
            DO 600 I = 1,NRAB
                 CALL YSTMT(ASNBUF(I),TKNCHN)
               SNUM = SNUM + 1
               CALL COMOUT(SNUM)
600            CONTINUE
            NRAB = 0
 
            NUMF = SNUM
            CALL PDOSEQ(DOVAR,E1,E2,E3,FIRST,LAST,NRDOS,NUMF,NUML,
     +                    LSTOUT)
            SNUM = NUML
            SPTR = LSTOUT
            GO TO 200
         END IF
      ELSE
C Statement is not a DO.  If it is an assignment statement place it
C in the assignment buffer.
         IF (NODETP(SPTR) .EQ. 49) THEN
            NRAB = NRAB + 1
            IF (NRAB .GT. 200) CALL ERROR ('ISTCD: Dimension Of '
     +            //'ASNBUF Too Small.')
            ASNBUF(NRAB) = SPTR
         ELSE
C Statement is neither an assignment nor a DO.  Output the assignment
C buffer and the statement.
            DO 400 I = 1,NRAB
                 CALL YSTMT(ASNBUF(I),TKNCHN)
               SNUM = SNUM + 1
               CALL COMOUT(SNUM)
400            CONTINUE
            NRAB = 0
              CALL YSTMT(SPTR,TKNCHN)
            SNUM = SNUM + 1
            CALL COMOUT(SNUM)
         END IF
      END IF
 
C Look for the next statement.
200     SPTR=ZYNEXT(SPTR)
        IF (SPTR.NE.0) GO TO 100
 
        END
